Notes from Time Seris Analysis 4th Edition

Chapter 1

1.1 The Nature of Time Series Data

library(pacman)
p_load(astsa)

## Example 1.1, Johnson and Johnson Quarterly Earnings
plot(jj, type="o", ylab="Quarterly Earnings per Share", main="Johnson and Johnson Quarterly Earnings")

## Explore analyzing data like this in Chapter 2 and 6

## Example 1.2 Global Warming
# Global mean land-ocean temperature index from 1880 to 2015
## Base period is 1951-1980
plot(globtemp, type="o", ylab="Global Temperature Deviations", main="Yearly average global temperature Devations")

## Example 1.3 Speech Data
# .1 (100 ms or 1 decisecond) 1000 point sample of recorded speech for the phrase "aaa...hhh"
# Spectral analysis can be used to produce a signature of this phrase that can be compared with signatures of various other library syllables to look for a match
# (Hmm..  I guess shazaam works something like this)
# Regular repetition of small wavelets
# Separatoin between the packets is known as the pitch period
plot(speech, ylab= "speech", main="100 ms Recording of 'Ah'")

Example 1.4 Dow Jones Industrial Average

Daily returns (or percent change) of the Dow Jones Industrial Average (DJIA) rom April 20 2006 to April 20 2016. Easy to spot the financial crisis of 2008 in the figure. Mean of the series is 0! Highly volatile (variable) periods tend to be clustered. A common problem in this analysis is to forecast the volatility of future returns.

Models to forecast volatility - ARCH and GARCH - stochastic volatility models - discuss in chapter 5 and 6z

Data obtained using the Technical Trading Rules (TTR) package to download the data from Yahoo and then plot it.

Used that fact that if \(x_t\) is the actual value of the DJIA and \(r_t = (x_t - x_{t-1})/x_{t-1}\) then \(1 + r_t = x_t/x_{t-1}\). Finally \[ \log(1 + r_t) = \log(x_t) - \log(x_{t-1}) \approx r_t \] where the last equality holds for small \(r_t\) because \[log(1 + p) = p - p^2/2 + p^3/3 - \cdots \] for \(p \in (-1,1]\)

# library(TTR)
# djia = getYahooData("^DJI", start=20060420, end=20160420, freq="daily")
p_load(xts)
djiar = diff(log(djia$Close))[-1] # approximate returns
plot(djiar, main="DJIA Returns", type="n")

lines(djiar)

Example 1.5 El Nino and Fish Population

  • Multiple interacting time series
    1. Southern Oscillation Index
    2. Associated recruitment (number of new fish)
  • bother series over 453 month period; 1950-1987
  1. SOI measures changes in air pressure, sea surface temperatures in the central pacific ocean
  • central Pacific warms every 3-7 years due to El Nino effect
  • periodic behavior is of interest because underlying processes of interest may be regular and the rate or frequency of oscillation characterizing the behavior of the underlying series would help to identify them
  • shows two basic oscillation types:
    • obvious annual cycle
    • slower frequency that seems to repeat about every 4 years.
  • the study of cycle and their strengths is the subject of Chapter 4

The series are likely related. So, some kind of time series regression is warranted. Call this Transfer function modeling. Study in Chapter 5.

par(mfrow = c(2,1)) # set up the graphics
plot(soi, ylab="", xlab="", main="Southern Oscillation Index")
plot(rec, ylab="", xlab="", main="Recruitment")

Example 1.6 fMRI Imaging

  • fundamental problem in classical statistics occurs when given a collection of independent series or vectors of series generated under varying experimental conditions or treatment configurations.
    • have series where observe data collected from various locations in the brain via functional MRI (fMRI). 5 subjects given period brushing on the hand. Stimulus was applied for 32 seconds then stopped for 32 seconds. The signal period is (therefore) 64 seconds. The sampling rate is one observation every 2 seconds for 256 seconds (n = 128).
      • average the results over subjects
        • (they were evoked responses and all subjects were in phase)
        • series show blood oxygenation-level dependent (BOLD) signal intensity
          • this measures areas of activation in the brain
          • periodicities appear strongly in the motor cortex, but less strongly in the thalamus and cerebellum
          • suggests testing whether the areas are responding differently to the brush stimuls
          • ANOVA techniques accomplish this in classical statistics
            • (ANOVA is the word they use for experimental design, basically)
          • Chapter 7 shows how ANOVA techniques (again, experimental design) in classical stats extend to time series data.
            • this leads to spectral analysis of variance
              • (Again, I don’t why they say analysis of variance, but they mean comparing results in an experiment. spectral is for time series part)
# My guess is each color is a different individual under treatment
par(mfrow=c(2,1))
ts.plot(fmri1[,2:5], col=1:4, ylab="BOLD", main="Cortex")
ts.plot(fmri1[,6:9], col=1:4, ylab="BOLD", main="Thalamus & Cerebellum")

Example 1.7 Earthquakes and Explosions

Two arrivals at a seismic recording station. - They are divided into two phases, P(t = 1, …, 1024) and S(t = 1025, … 2048) - They are from recording instruments in Scandinavia - They are observing earthquakes adn mining explosions with one of each shown in Figure 1.7. - The general problem of interest is in distinguishing or discriminating between waveforms generated by earthquakes and waveforms generated by explosions. - Features that may be important are the rough maximum amplitude ratios of the first phase P to the second phase S; the amplitude ratio tends to be smaller for earthquakes than for explosions. - In the case of this data, the ratio appears to be less than .5 for earthquakes () and about 1 for explosion. (I don’t know if that’s true for explosion. Certainly closer to 1 for explosion than for earthquake, though.)

par(mfrow=c(2,1))
plot(EQ5, main="Earthquake")
plot(EXP6, main="Explosion")

1.2 Time Series Statistical Models

Goal: produce plausible descriptions for sample data - Assume a time series can be defined as a collection of random variables indexed according to the order they are observed - In general, collection of random variables is called a stochastic process - the observed values are called the realization - since clear from context, time series can refer to either the stochastic process or its realization - appearance of data can be changed completely by adopting an insufficient sampling rate: - wheels in old movies can appear to be turning backwards because of insufficient number of frames sampled by the camera! (it’s interesting to think that movies are actually time series data…) -

Example 1.8 White Noise (3 flavors) - A simple kind of generated series might be a collectoin of uncorrelated random variables, \(w_t\). mean 0 finite variance \(\sigma_w^2\). Write \[w_t \sim wn(0, \sigma_w^2)\]. It’s called white because its like white light; all possible periodic oscillations are present. - If want iid white noise, write it as \(w_t \sim iid(0, \sigma_w^2)\).

Note that white noise cannot describe all time series behavior!. (of course). Two ways of introducing serial correlatoin and more smoothness into time series are given below (Example 1.9 and 1.10).

Example 1.9 Moving AVerages and Filtering Replace white noise series \(w_t\) by a moving average that smooths the series. e.g. \(v_t = \frac{1}{3} (w_{t-1} + w_t + w_{t+1})\) which leads to series shown below. The white noise series is less smooth than the moving average sequence. (I guess you could make any time series look like a line plot by adding enough autocorrelation to the plot. For example, you can almost always say the relationship between y and x doesn’t really exist and instead it is driven by spurious correlatoin between x and the errors. Like X is increasing over time and the errors average level is also increasing over time and it makes it look like y is increasing with x. The question is when can you cast enough reasonable doubt on this idea to still make the claim. I think that is inherently what Carlos and Rosa are arguing with many practicioners: while the practicioners might be right, Rosa and Carlos want them to due more to eliminate other possibilities before making their conclusions. Of course, there is almost always room for people to be wrong.)

Note that a linear combination of values in a time series (as \(v_t\) is) is called a filter. That’s why use “filter” code to generate v. (This explains some of the confusing and unexplained terminology in Liao’s class, too.)

w = rnorm(500,0,1)
# 500 N(0,1) variates
v = filter(w, sides=2, filter=rep(1/3,3)) # moving average
par(mfrow=c(2,1))
plot.ts(w, main="white noise")
plot.ts(v, ylim=c(-3,3), main="moving average")

When there is some kind of quasi-periodic behavior (i.e. sinusoidal-ish shapes), we expect autoregressive model. Consider these in Chapter 3.

(Note that, there is always some underlying cause of the time series. Just when we model time series, we are recognizing that there is some time-varying correlation between the unobservable causes! But the unobservables aren’t “errors”. Maybe a better term for the “error” is unexplainables. But we are always saying “we can’t explain it with what we see but we can still predict some things from it”. So, in the background, there is always some variable going up and down. Like the sun for the weather. The sun is ultimately driven by some periodic process too. With stocks, the question is tougher. What is the underlying unobservable process?

Example 1.10 Autoregressions

Note that autoregression is still a filter of white noise, as it is a linear combination of variables. Indeed, it is referred to as a recursive filter.

We can let \(x_t\) be a second-order equation: \[x_t = x_{t-1} - .9 x_{t-2} + w_t\] successively for \(t = 1, 2, ..., 500\).

The filter function defaults to use zeros for the initial values. in this case \(x_1 = w_1\)

w = rnorm(550,0,1)
# 50 extra to avoid startup problems
x = filter(w, filter=c(1,-.9), method="recursive")[-(1:50)] # remove first 50
plot.ts(x, main="autoregression")

Example 1.11 Random Walk with Drift \(\delta\) is the drift term. t = 1,2, .., and initial condition \(x_0 = 0\). If \(\delta = 0\), then it’s just a random walk.

\[x_t = \delta + x_{t-1} + w_t\]

Note we can rewrite this: \(x_t = \delta t + \sum_{j = 1} ^t w_j\)

set.seed(154)
# so you can reproduce the results
w = rnorm(200); x = cumsum(w)
# two commands in one line
wd = w +.2;
xd = cumsum(wd)
plot.ts(xd, ylim=c(-5,55), main="random walk", ylab='')
lines(x, col=4); abline(h=0, col=4, lty=2); abline(a=0, b=.2, lty=2)

Example 1.12 Signal in Noise

Many realistic models for generating time series assume an underlying signal with some consistent periodic variation, contaminated by adding a random noise.

Model: \[x_t = 2 \cos(2\pi\frac{15 + t}{50}) + w_t\]

(Note that we are actually putting a function of t into the model! Not just putting it all into the noise.)

Note that a sinusoidal waveform can be written as \[A cos(2 \pi \omega t + \phi)\] where A is the amplitude, \(\omega\) is the frequency of oscillation and \(\phi\) is a phase shift.

An additive white noise term can easily obscure the pattern! Look:

cs = 2*cos(2*pi*1:500/50 + .6*pi); w = rnorm(500,0,1)
par(mfrow=c(3,1), mar=c(3,2,2,1), cex.main=1.5)
plot.ts(cs, main=expression(2*cos(2*pi*t/50+.6*pi)))
plot.ts(cs+w, main=expression(2*cos(2*pi*t/50+.6*pi) + N(0,1)))
plot.ts(cs+5*w, main=expression(2*cos(2*pi*t/50+.6*pi) + N(0,25)))

That’s actually pretty interesting.

In Chapter 4, study spectral analysis as a possible technique for detecting regular or periodic signals. In general, authors want to emphasize the importance of simple additive models such as \[x_t = s_t + v_t \tag{1.7}\] where \(s_t\) denotes some unknown signal and \(v_t\) denotes a time series taht may be white or correlated over time. Signal deterecting is very important in engineering and sciences. In economics, the underlying signal may be a trend or a seasonal component of a series. (Hmm… is that right? What if I want to find demand events? ) Models such as 1.7 above form the motivation of state-space models in Chapter 6.

Note that correlation is an essential feature of time series analysis. So, the “most useful” descriptive measures are those expressed in terms of covariance and correlation functions (As an aside, it is just annoying because it doesn’t seem like )

1.3 Measures of Dependence

These sections are math intensive and noted by hand.

1.4 Stationary Time Series

Below is the code for example 1.24 when lag is 5. You can see the estimation actually worked reasonably well in the sense that the only true correlation looks pretty big and the rest look pretty small. Note, the larger the lag, the fewer the data points you can use to estimate it.

x = rnorm(100)
y = lag(x, -5) + rnorm(100)
ccf(y, x, ylab='CCovF', type='covariance')

1.5 Estimating Autocorrelation

Note, these estimators are built on the premise that the series is stationary, I believe. Note that our estimator divides by n and not n-h. This guarantees that our estimator is nonnegative. Neither dividing by n nor dividing by n-h would lead to an unbiased estimator.

If \(\bar{x} =\frac{1}{n} \sum_{j = 1}^n x_j\) and series is stationary, then \[E(\bar{x}) = \mu\] and \[ var(\bar{x}) = \frac{1}{n} \sum_{h = -n}^n (1-\frac{|h|}{n})\gamma_x(h)\]

Sample autocovariance is estimated by \[\hat{\gamma}(h) = n^{-1}\sum_{t=1}^{n-h}(x_{t+h} - \bar{x})(x_t - \bar{x})\] The sample autocorrelation function is estimated by \[\hat{\rho}(h) = \frac{\hat{\gamma}(h)}{\hat{\gamma}(0)} \]

Example 1.26 A Simulated Time Series.

\(y_t = 5 + x_t - .7x_{t-1}\) where \(x_t = -1\) or \(1\) with equal probability, independent over time. Then, \(\rho_y(1) = -.47 = -.7/(1+.7^2)\) and \(\rho_y(h)\) is 0 for all h greater in absolute value than 1. (Of course, \(\hat{\rho}_y(0) = 1 = \rho_y(0)\) as a mathematical certainty.). The 100 series sample below gets it pretty close (although the 10 serise sample does not!)

Recall that autocorrelation (for stationary time series) is the linear dependence of observations \(h\) steps ahead of \(t\) are on observations at step \(t\) for all \(t\).

set.seed(101010)
x1 = 2*rbinom(11, 1, .5) - 1
# simulated sequence of coin tosses
x2 = 2*rbinom(101, 1, .5) - 1
y1 = 5 + filter(x1, sides=1, filter=c(1,-.7))[-1]
y2 = 5 + filter(x2, sides=1, filter=c(1,-.7))[-1]
plot.ts(y1, type='s'); plot.ts(y2, type='s')

# plot both series (not shown)
c(mean(y1), mean(y2))
## [1] 5.080 5.002
# the sample means

acf(y1, lag.max=4, plot=FALSE) # 1/ 10 = .32
## 
## Autocorrelations of series 'y1', by lag
## 
##      0      1      2      3      4 
##  1.000 -0.688  0.425 -0.306 -0.007
# Autocorrelations of series 'y1', by lag

acf(y2, lag.max=4, plot=FALSE) # 1/ 100 = .1
## 
## Autocorrelations of series 'y2', by lag
## 
##      0      1      2      3      4 
##  1.000 -0.480 -0.002 -0.004  0.000
#Autocorrelations of series 'y2', by lag
# Note that the sample ACF at lag zero is always 1 (Why?).

Example 1.28 SOI and Recruitment Correlation Analysis

Comparing ACF of two potentially related series can be useful, as can looking at the CCF of the series. Its not clear what to conclude from these (to me, yet), but it certainly looks like there is some relationship.

par(mfrow=c(3,1))
acf(soi, 48, main="Southern Oscillation Index")
acf(rec, 48, main="Recruitment")
ccf(soi, rec, 48, main="SOI vs Recruitment", ylab="CCF")

Example 1.29: Prewhitening and cross-correlation analysis.

Property 1.3 requires at least one of our series to be white noisse for the crosscorrelation asymptotic distribution to hold. This is not the case for the series below.

Suppose \[x_t = 2 \cos(\frac{2 \pi t}{12}) + w_{t1}\] \[y_t = 2 \cos\left ( \frac{2 \pi}{12}(t + 5) \right ) + w_{t2}\] where \(w_{ti}\) are iid N(0,1) over t and i. It looks like the series have cross correlation, although they are actually independent.

__(Note, interpreting this actually hinges on a very subtle understanding of independence and correlation. The series both do exhibit dependence on \(t\). So, for many intents and purposes, the series are not “independent”. However, statistically speaking, the deterministic components of the processes have no variance! In particular, even though t varies, it is a deterministic time step. Therefore, the series \(x_t\) variations as a function of \(t\) are not stochastic variations and therefore not a source of correlation. I feel like this is somewhat a failing of how we are thinking of the statistics here. More broadly, if f is some deterministic function of time and x_t = f(t) + _t and y_t = f(t) + _t where the and are iid normals, then y_t may lead to excellent information predicting x_t but are not linearly correlated. However, if we re-imagine f(t) as our observable (which it may not be) then we can now see how x_t covaries with f(t) and will get strong correlation…)__

set.seed(1492)
num=120; t=1:num
X = ts(2*cos(2*pi*t/12) + rnorm(num), freq=12)
Y = ts(2*cos(2*pi*(t+5)/12) + rnorm(num), freq=12)
Yw = resid( lm(Y~ cos(2*pi*t/12) + sin(2*pi*t/12), na.action=NULL) )
par(mfrow=c(3,2), mgp=c(1.6,.6,0), mar=c(3,3,1,1) )
plot(X)
plot(Y)
acf(X,48, ylab='ACF(X)')
acf(Y,48, ylab='ACF(Y)')
ccf(X,Y,24, ylab='CCF(X,Y)')
ccf(X,Yw,24, ylab='CCF(X,Yw)', ylim=c(-.6,.6))

Example 1.30 Soil Surface Temperatrues Surface temperatures on a 64 by 36 grid. The value of the temperature measured at row \(s_1\) and column \(s_2\) is denoted by \(x_s = x_{s1, s2}\). (I think this series doesn’t actually vary over time, just space)

persp(1:64, 1:36, soiltemp, phi=25, theta=25, scale=FALSE, expand=4,
ticktype="detailed", xlab="rows", ylab="cols", zlab="temperature")

plot.ts(rowMeans(soiltemp), xlab="row", ylab="Average Temperature")

Example 1.31

Calculating aCF for the process above. The fastest way to do it is with a FFT (fast Fourier transform). This is covered in Chapter 4. Have to take their word here. rs is the ACF. the rest is to tidy it up. Sampling for multidimensional processes are very strict; In some areas of application, they sample a limited number of rows or transects and hope these are essentially replicates of the basic underlying phenomenon of interest.

fs = Mod(fft(soiltemp-mean(soiltemp)))^2/(64*36)
cs = Re(fft(fs, inverse=TRUE)/sqrt(64*36)) # ACovF
rs = cs/cs[1,1]
# ACF
rs2 = cbind(rs[1:41,21:2], rs[1:41,1:21])
rs3 = rbind(rs2[41:2,], rs2)
par(mar = c(1,2.5,0,0)+.1)
persp(-40:40, -20:20, rs3, phi=30, theta=30, expand=30, scale="FALSE",
ticktype="detailed", xlab="row lags", ylab="column lags",
zlab="ACF")

Chapter 2 Time Series REgression and Exploratory Analysis

Start with simple regression model:

\[x_t = \beta_0 + \beta_1 z_{t1} + \cdots + \beta_q z_{tq} + w_t \] where we assume \(w_t\) is iid \(N(0, \sigma_w^2)\). Can fit with OLS.

summary(fit <- lm(chicken~time(chicken), na.action=NULL))
## 
## Call:
## lm(formula = chicken ~ time(chicken), na.action = NULL)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -8.7411 -3.4730  0.8251  2.7738 11.5804 
## 
## Coefficients:
##                 Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   -7.131e+03  1.624e+02  -43.91   <2e-16 ***
## time(chicken)  3.592e+00  8.084e-02   44.43   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 4.696 on 178 degrees of freedom
## Multiple R-squared:  0.9173, Adjusted R-squared:  0.9168 
## F-statistic:  1974 on 1 and 178 DF,  p-value: < 2.2e-16
plot(chicken, ylab="cents per pound")
abline(fit)

# add the fitted line

Example 2.2 Looking at mortality vs temperature and pollutants in Los Angeles

par(mfrow=c(3,1)) # plot the data
plot(cmort, main="Cardiovascular Mortality", xlab="", ylab="")
plot(tempr, main="Temperature", xlab="", ylab="")
plot(part, main="Particulates", xlab="", ylab="")

dev.new()
# open a new graphic device
ts.plot(cmort,tempr,part, col=1:3) # all on same plot (not shown)
dev.new()
pairs(cbind(Mortality=cmort, Temperature=tempr, Particulates=part))
temp = tempr-mean(tempr) # center temperature
temp2 = temp^2
trend = time(cmort)
# time
fit = lm(cmort~ trend + temp + temp2 + part, na.action=NULL)
summary(fit)
## 
## Call:
## lm(formula = cmort ~ trend + temp + temp2 + part, na.action = NULL)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -19.0760  -4.2153  -0.4878   3.7435  29.2448 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  2.831e+03  1.996e+02   14.19  < 2e-16 ***
## trend       -1.396e+00  1.010e-01  -13.82  < 2e-16 ***
## temp        -4.725e-01  3.162e-02  -14.94  < 2e-16 ***
## temp2        2.259e-02  2.827e-03    7.99 9.26e-15 ***
## part         2.554e-01  1.886e-02   13.54  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6.385 on 503 degrees of freedom
## Multiple R-squared:  0.5954, Adjusted R-squared:  0.5922 
## F-statistic:   185 on 4 and 503 DF,  p-value: < 2.2e-16
# regression results
summary(aov(fit))
##              Df Sum Sq Mean Sq F value Pr(>F)    
## trend         1  10667   10667  261.62 <2e-16 ***
## temp          1   8607    8607  211.09 <2e-16 ***
## temp2         1   3429    3429   84.09 <2e-16 ***
## part          1   7476    7476  183.36 <2e-16 ***
## Residuals   503  20508      41                   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
# ANOVA table
# (compare to next line)
summary(aov(lm(cmort~cbind(trend, temp, temp2, part)))) # Table 2.1
##                                  Df Sum Sq Mean Sq F value Pr(>F)    
## cbind(trend, temp, temp2, part)   4  30178    7545     185 <2e-16 ***
## Residuals                       503  20508      41                   
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
num = length(cmort)
# sample size
AIC(fit)/num - log(2*pi) # AIC
## [1] 4.721732
BIC(fit)/num - log(2*pi) # BIC
## [1] 4.771699
(AICc = log(sum(resid(fit)^2)/num) + (num+5)/(num-5-2)) # AICc
## [1] 4.722062

Example 2.3 Regression with Lagged Variables

fish = ts.intersect(rec, soiL6=lag(soi,-6), dframe=TRUE)
summary(fit1 <- lm(rec~soiL6, data=fish, na.action=NULL))
## 
## Call:
## lm(formula = rec ~ soiL6, data = fish, na.action = NULL)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -65.187 -18.234   0.354  16.580  55.790 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   65.790      1.088   60.47   <2e-16 ***
## soiL6        -44.283      2.781  -15.92   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 22.5 on 445 degrees of freedom
## Multiple R-squared:  0.3629, Adjusted R-squared:  0.3615 
## F-statistic: 253.5 on 1 and 445 DF,  p-value: < 2.2e-16
# can make aligning the lagged series easier with dynlm
p_load(dynlm)
summary(fit2 <- dynlm(rec~ L(soi,6)))
## 
## Time series regression with "ts" data:
## Start = 1950(7), End = 1987(9)
## 
## Call:
## dynlm(formula = rec ~ L(soi, 6))
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -65.187 -18.234   0.354  16.580  55.790 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   65.790      1.088   60.47   <2e-16 ***
## L(soi, 6)    -44.283      2.781  -15.92   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 22.5 on 445 degrees of freedom
## Multiple R-squared:  0.3629, Adjusted R-squared:  0.3615 
## F-statistic: 253.5 on 1 and 445 DF,  p-value: < 2.2e-16
#fit2 is similar to fit1 but time series attributes are retained without any additional commands

2.2 Exploratory Data Analysis

Differencing Chicken Prices

fit = lm(chicken~time(chicken), na.action=NULL) # regress chicken on time
par(mfrow=c(2,1))
plot(resid(fit), type="o", main="detrended")
plot(diff(chicken), type="o", main="first difference")

par(mfrow=c(3,1)) # plot ACFs
acf(chicken, 48, main="chicken")
acf(resid(fit), 48, main="detrended")
acf(diff(chicken), 48, main="first difference")

Differenced series exhibits annual cycle that was obscured in the original or detrended data.

Example 2.6 Differencing Global Temperature

par(mfrow=c(2,1))
plot(diff(globtemp), type="o")
mean(diff(globtemp)) # drift estimate = .008
## [1] 0.007925926
acf(diff(gtemp), 48)

Example 2.7 Paleoclimatic Glacial Varves

Later show this is an example of a “long-memory” process. Explore this in Chapter 5. For now, use log transformation to make the amplitude smoother across time, effectively stationarizing the autocorrelation. (I guess if this works well, you can destationarize it by unlogging the autocorrelation and predicting in that case!)

par(mfrow=c(2,1))
plot(varve, main="varve", ylab="")
plot(log(varve), main="log(varve)", ylab="" )

Example 2.8: Scatterplot Matrices, SOI and Recruitment

Idea is to plot \(x_t\) vs \(x_{t-h}\) or \(y_t\) vs \(x_{t-h}\) to look at linearities and nonlinearities that the eye can detect in the lagged series.

The red lines superimposed on the scatterplot are locally weighted scatterplot smoothing (lowess) lines. (i.e. LOcally WEighted Scatterplot Smoothing = lowess.) Lowess is a robust method for fitting local regression.

When the lowess lines are straight, correlation can be meaningfully interpreted. When the lowess lines are not straight, the correlation cannot be meaningfully interpreted.

For example, SOI_t vs its lags looks pretty straight. So, we can interpret autocorrelation. However, Recruitment vs lags of SOI looks very curved. So, we shouldn’t interpret cross-correlations meaningfully.

lag1.plot(soi, 12) #soi_t vs soi_{t-h} up to h = 12

lag2.plot(soi, rec, 8) # rec_t on y, soi_{t-h} on x up to h = 8

Example 2.9 Accounting for nonlinearities

In example 2.3 did \(R_t = \beta_0 + \beta_1 S_{t-6} + w_t\)

Since we see the nonlinearities in cross-correlation from 2.8 above, now we add the dummy variable \(D_t = 1(S_t \ge 0)\) and estimate the relationship \[R_t = \beta_0 + \beta_1 S_{t-6} + \beta_2 D_{t-6} + \beta_3 D_{t-6} S_{t-6} + w_t\] That is, we have

\[ R_t = \begin{cases} \beta_0 + \beta_1S_{t-6} + w_t \text{ if } S_{t-6} < 0,\\ \beta_0 + \beta_2 + (\beta_1 + \beta_3) S_{t-6} + w_t \text{ if } S_{t-6} \ge 0\end{cases} \]

dummy = ifelse(soi<0, 0, 1)
fish = ts.intersect(rec, soiL6=lag(soi,-6), dL6=lag(dummy,-6), dframe=TRUE)
summary(fit <- lm(rec~ soiL6*dL6, data=fish, na.action=NULL))
## 
## Call:
## lm(formula = rec ~ soiL6 * dL6, data = fish, na.action = NULL)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -63.291 -15.821   2.224  15.791  61.788 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   74.479      2.865  25.998  < 2e-16 ***
## soiL6        -15.358      7.401  -2.075   0.0386 *  
## dL6           -1.139      3.711  -0.307   0.7590    
## soiL6:dL6    -51.244      9.523  -5.381  1.2e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 21.84 on 443 degrees of freedom
## Multiple R-squared:  0.4024, Adjusted R-squared:  0.3984 
## F-statistic: 99.43 on 3 and 443 DF,  p-value: < 2.2e-16
attach(fish)
## The following object is masked from package:astsa:
## 
##     rec
plot(soiL6, rec)
lines(lowess(soiL6, rec), col=4, lwd=2)
points(soiL6, fitted(fit), pch='+', col=2)

plot(resid(fit)) # not shown ...

acf(resid(fit))

# ... but obviously not noise

Note that the residuals very clearly display autocorrelation. So, our modeling assumptions would appear to be incorrect, still.

Example 2.10 Using Regression to Discover a Signal in Noise. We are looking for cyclic or periodic signals in time series here.

In previous example, generated 500 observatinos from the model \[ x_t = A cos(2 \pi \omega t + \phi) + w_t\] where \(\omega = 1/50, A = 2, \phi = .6 \pi\) and \(\sigma_w = 5\). Assume that \(\omega = 1/50\), the frequency of oscillation is known but that A and are unknown. (In my problem, the frequency of oscillation is known and is one year.)

Use the trig identity \[ A Cos (2 \pi \omega t + \phi ) = \beta_1 \cos(2 \pi \omega t) + \beta_2 \sin (2 \pi \omega t) \] where \(\beta_1 = A \cos(\phi)\) and \(\beta_2 = -A \sin(\phi)\) and then can run the regression \[ x_t = \beta_1 \cos(2\pi t/50) + \beta_2 \sin(2 \pi t/50) + w_t\]

set.seed(90210)
# so you can reproduce these results
x = 2*cos(2*pi*1:500/50 + .6*pi) + rnorm(500,0,5)
z1 = cos(2*pi*1:500/50)
z2 = sin(2*pi*1:500/50)
summary(fit <- lm(x~0+z1+z2)) # zero to exclude the intercept
## 
## Call:
## lm(formula = x ~ 0 + z1 + z2)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -14.8584  -3.8525  -0.3186   3.3487  15.5440 
## 
## Coefficients:
##    Estimate Std. Error t value Pr(>|t|)    
## z1  -0.7442     0.3274  -2.273   0.0235 *  
## z2  -1.9949     0.3274  -6.093 2.23e-09 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 5.177 on 498 degrees of freedom
## Multiple R-squared:  0.07827,    Adjusted R-squared:  0.07456 
## F-statistic: 21.14 on 2 and 498 DF,  p-value: 1.538e-09
par(mfrow=c(2,1))
plot.ts(x)
plot.ts(x, col=8, ylab=expression(hat(x)))
lines(fitted(fit), col=2)

Discuss this in more detail in Chapter 4!!!

2.3 Smoothing in the Time Series Context

In example 1.9 discussed using a moving average to smooth white noise. Useful for discovering long-term trend and seasonal components (???). \[m_t = \sum_{j=-k}^k a_j x_{t-j} \] with \(a_j = a_{-j}\) and \(\sum_{j = -k}^k a_j = 1\) is a symmetric moving average of the data.

Example 2.11 Moving Average Smoother.

wgts = c(.5, rep(1,11), .5)/12
soif = filter(soi, sides=2, filter=wgts)
plot(soi)
lines(soif, lwd=2, col=4)
par(fig = c(.65, 1, .65, 1), new = TRUE) # the insert
nwgts = c(rep(0,20), wgts, rep(0,20))
plot(nwgts, type="l", ylim = c(-.02,.1), xaxt='n', yaxt='n', ann=FALSE)

Example 2.12 Kernel Smoothing

ksmooth makes it so that the kernels are scaled so that their quartiles are plus or minus .25*bandwidth. Does the Nadarya-Watson estimator. bandwidth = 1 smoothes over the year (we’ve seen this).

Note that the moving average smoother is a boxy way of smoothing in the following sense: it takes everything within the moving average window into account and has no weight for anything out of it. In contrast, the (exponential) kernel smoother is a bell curve of smoothing in the following sense: all points get incorporated in, just the farther away they are, the less the effect matters.

plot(soi)
lines(ksmooth(time(soi), soi, "normal", bandwidth=1), lwd=2, col=4)
par(fig = c(.65, 1, .65, 1), new = TRUE) # the insert
gauss = function(x) { 1/sqrt(2*pi) * exp(-(x^2)/2) }
x = seq(from = -3, to = 3, by = 0.001)
plot(x, gauss(x), type ="l", ylim=c(-.02,.45), xaxt='n', yaxt='n', ann=FALSE)

Example 2.13 Lowess

Nearest neighbor regression. Technique is based on k-nearest neighbors regression. Idea: you use \(\set{x_{t-k/2}, ..., x_t, ..., x_{t+k/2}}\) to predict \(x_t\) via regression and then set \(m_t = \hat{x}_t\). The larger k, the smoother it will be. (This is the default smoothing in ggplot2! for geom_smooth()). Recall that the SOI records changes in air pressure, which is related to sea surface temperatures in the central Pacific Ocean. The pacific warms every 3-7 years due to the El Nino effect. Dates are 1950 to 1985. This site describes it better than the textbook: http://www.bom.gov.au/climate/enso/history/ln-2010-12/SOI-what.shtml#:~:text=The%20Southern%20Oscillation%20Index%20(SOI)%20is%20a%20measure%20of%20the,impacts%20on%20the%20Australian%20region. The SOI measures teh difference between the surface air pressure in Tahiti and Darwin Australia. The pattern is best respresented by monthly or longer averages as daily or weekly SOI values can fluctuate markedly due to short-lived day-to-day weather patterns. Sustained postiive indicate La Nina, whereas sustained negative below -8 indicate an El Nino. Prolonged periods of negative SOI values coincide with abnormally warm ocean waters across the eastern tropical Pacific. The warm is typical of El Nino. The cold (with its positive SOI values) indicate La Nina episodes.

So I guess the downward trend in this series is consistent with average increases in oceanic temperature. Can also check here: https://www.ncdc.noaa.gov/teleconnections/enso/indicators/soi/. I don’t know how safe it is to conclude temperature things from this trend though. I don’t understand the relationship completely between temperature and pressure differences.

plot(soi)
lines(lowess(soi, f=.05), lwd=2, col=4)
# El Nino cycle
lines(lowess(soi), lty=2, lwd=2, col=2)

# trend (with default span)

Example 2.14 Smoothing Splines

\(x_t = m_t + w_t\) where \(m_t = \beta_0 + \beta_1 t + \beta_2 t^2 + \beta_3 t^3\). Extend to splines by dividing \(t = 1, ..., n\) into k intervals: \([t_0 = 1, t_1], [t_1 + 1, t_2], ..., [t_{k-1} + 1, t_k = n]\). the values \(t_0, t_1, ..., t_k\) are called knots. If fit a (typically cubic) polynomial into each intervall, call it (cubic) splines.

Smoothing splines are similar to cubic splines, but they add a penalty term that penalizes more jagged changes.

R’s smoothing parameter is called spar. It is monotonically related to \(\lambda\). The larger \(\lambda\) the smoother the fit.

plot(soi)
lines(smooth.spline(time(soi), soi, spar=.5), lwd=2, col=4)
lines(smooth.spline(time(soi), soi, spar= 1), lty=2, lwd=2, col=2)

?smooth.splilne
## No documentation for 'smooth.splilne' in specified packages and libraries:
## you could try '??smooth.splilne'

Example 2.15 Smoothing One Series as a Function of Another

Here, smooth the scatterplot of two contemporaneously measured time series, mortality as a function of temperature. Mortality \(M_t\), temperature \(T_t\)

plot(tempr, cmort, xlab="Temperature", ylab="Mortality")
lines(lowess(tempr, cmort))

Chapter 3 ARIMA Models

  • ARMA models proposed by Whittle 1951
  • ARIMA Models Proposed by Box and Jenkins 1970

3.1 ARMA Models

Can assess forecastability of a time series by looking at its autocorrelation function and the lagged scatterplot matrices.

Example 3.1 AR(1) Process

\[E(x_t) = 0\] \[ \gamma(h) = \frac{\sigma_w^2 \phi^h}{1 - \phi^2}\] \[ \rho(h) = \gamma(h)/\gamma(0) = \phi^h \]

Example 3.2 Sample Path of an AR(1) Process

par(mfrow=c(2,1))
plot(arima.sim(list(order=c(1,0,0), ar=.9), n=100), ylab="x",
main=(expression(AR(1)~~~phi==+.9)))
plot(arima.sim(list(order=c(1,0,0), ar=-.9), n=100), ylab="x",
main=(expression(AR(1)~~~phi==-.9)))

Note that with \(\phi = .9\) the autocorrelation decays steadily. With \(\phi = -.9\) the autocorrelatoin oscillates as it decays.

Example 3.3 Explosive AR Models are Not Causal

Note that a random walk has \(x_t = x_{t-1} + w_t\) would be an \(AR(1)\) process with \(\phi = 1\), except AR(1) are not defined for \(\phi = 1\) since they are not stationary here. Note, we can find a stationary model for \(|\phi| > 1\) however. In particular, for \(k>0\), note that \(x_t = \phi^{-k}x_{t + k} - \sum_{j = 1}^{k-1} \phi^{-j}w_{t+j}\) So \[x_t = -\sum_{j=1}^\infty \phi^{-j} w_{t+j} \] This is actually stationary! But it is future dependent and therefore not causal.

Example 3.5 Plotting MA Models

Moving Average with positive coefficient seems to make it sticky within plus or -1 either step, not “smooth” like the AR(1) process with positive coefficient. When it is negative, it really just jumps back and forth across 0. We don’t see the same amplitude oscillation with the MA(1) process with negative coefficient as we do with the AR(1) process with negative coefficient.

par(mfrow = c(2,1))
plot(arima.sim(list(order=c(0,0,1), ma=.9), n=100), ylab="x",
main=(expression(MA(1)~~~theta==+.5)))
plot(arima.sim(list(order=c(0,0,1), ma=-.9), n=100), ylab="x",
main=(expression(MA(1)~~~theta==-.5)))

Example 3.7 Parameter Redundancy

This is an important example. Note that if \(x_t = w_t\)–that is, \(x_t\) is a whie noise process–then its also true that \[x_t = .5 x_{t-1} - .5w_{t-1} + w_t\] whick looks like an ARMA(1,1) model. We have hidden the underlying white noise model in an over-parameterized model. Indeed, running an ARMA(1,1) regression on 150 normal r.v. gives is -1 and 1 for coefficients!

set.seed(8675309) # Jenny, I got your number
x = rnorm(150, mean=5) # generate iid N(5,1)s
arima(x, order=c(1,0,1)) # estimation
## 
## Call:
## arima(x = x, order = c(1, 0, 1))
## 
## Coefficients:
##           ar1     ma1  intercept
##       -0.9595  0.9527     5.0462
## s.e.   0.1688  0.1750     0.0727
## 
## sigma^2 estimated as 0.7986:  log likelihood = -195.98,  aic = 399.96

To overcome the overparameterization, we require some additional restrictions on the model parameters.

As summary, the problems we have seen so far are as follows. 1. parameter redundant models 2. stationary AR models that depend on the future 3. MA models that are not unique

Example 3.8

Model starts as \[x_t = .4x_{t-1} + .45x_{t-2} + w_t + w_{t-1} + .25 w_{t-2}\] or in operator form \[(1 - .4B - .45B^2)x_t = (1 + B + .25B^2) w_t\] At first, \(x_t\) appears to be an ARMA(2,2) process, but the shared roots of \[\phi(z) = (1 + .5z)(1 - .9z)\] and \[\theta(z) = (1 + .5z)^2\] have a common factor that can be canceled. Simplifies to \[x_t = .9 x_{t-1} + .5 w_{t-1} + w_t\]

By property 3.1, we can convert the model to a linear process by solving \[ \phi(z) \psi(z) = \theta(z)\] or \[(1 - .9z) (1 + \psi_1 z + \psi_2 z^2 + \cdots + \psi_j z_j + \cdots) = 1 + .5 z \] so \[x_t = w_t + 1.4 \sum_{j = 1}^\infty .9^{j-1} w_{t-j}\]

(i.e. solve \(\psi(z)\phi(z) = \theta(z)\))

R will calculate the values of \(\psi\) series with the following code!

ARMAtoMA(ar = .9, ma = .5, 10) # first 10 psi-weights
##  [1] 1.4000000 1.2600000 1.1340000 1.0206000 0.9185400 0.8266860 0.7440174
##  [8] 0.6696157 0.6026541 0.5423887

To convert the model to its invertible form, we set \(\pi(z)\theta(z) = \phi(z)\) and solve for \(\pi(z)\). (The fact that \(\theta_1 = .5\) ensures its roots are outside the unit circle. Rather than \(\theta_1 = 2\). So \[ (1 + .5z) (1 + \pi_1 z + \pi_2 z^2 + \pi_3 z^3 + \cdots ) = 1 - .9z\] and therefore \(\pi_j = (-1)^j 1.4 (.5)^{j-1}\) for \(j \ge 1\). So \[x_t = 1.4 \sum_{j=1}^\infty (-.5)^{j-1}x_{t-j} + w_t\]

To calculate the sequence with R:

ARMAtoMA(ar = -.5, ma = -.9, 10)
##  [1] -1.400000000  0.700000000 -0.350000000  0.175000000 -0.087500000
##  [6]  0.043750000 -0.021875000  0.010937500 -0.005468750  0.002734375
# first 10 pi-weights
#[1] -1.400 .700 -.350 .175 -.087 .044 -.022 .011 -.006 .003

Example 3.11 An AR(2) with Complex Roots

\[x_t = 1.5 x_{t-1} - .75x_{t-2} + w_t \] with \(\sigma_w^2= 1\). The autoregressive polynomial for this model is \(\phi(z)=1 - 1.5z + .75z^2\) This is because \(\phi(B) = 1 - 1.5B + .75B^2\) and \(\theta(B) = 1\) and they therefore have no common roots. (It’s much easier to analyze if just an AR or just an MA). The roots are \(1 \pm i/\sqrt{3}\). So \(\theta = \pi/6\) and therefore we can convert the angle to cycles per unit time by diving by \(2 \pi\), which leaves us with \(1/12\) cyles per unit time. That is, 1 autocorrelation cycle every 12 time steps. Note that the angle \(\theta\) (restricted to be within \((-\pi, \pi]\) is often called the arg(z) or the argument of z. \(1/(\theta/2\pi)=2 \pi/ \theta\) is how many time steps to a cycle.

# Calculating the roots in R
z = c(1,-1.5,.75)
(a = polyroot(z)[1])
## [1] 1+0.57735i
#[1] 1+0.57735i
arg = Arg(a)/(2*pi)
1/arg
## [1] 12
#[1] 12
# Arg(a) is angle theta

set.seed(8675309)
ar2 = arima.sim(list(order=c(2,0,0), ar=c(1.5,-.75)), n = 144) #i.e. AR(2) process
plot(ar2, axes=FALSE, xlab="Time")
axis(2); axis(1, at=seq(0,144,by=12)); box()
abline(v=seq(0,144,by=12), lty=2)

ACF = ARMAacf(ar=c(1.5,-.75), ma=0, 50)
plot(ACF, type="h", xlab="lag")
abline(h=0)

Example 3.12 The \(\psi\)-weights for an ARMA Model

\(x_t = .9x_{t-1} + .5w_{t-1} + w_t\)

The \(\psi\)-weights are the weights for the function in causal form.

The R code below generate the first 50 \(\psi\)-weights. We know from solving it by hand that \(\psi_1 =1.4\), \(\psi_j = 1.4(.9)^{j-1}\) for \(j \ge 2\).

ARMAtoMA(ar=.9, ma=.5, 50) # for a list
##  [1] 1.400000000 1.260000000 1.134000000 1.020600000 0.918540000 0.826686000
##  [7] 0.744017400 0.669615660 0.602654094 0.542388685 0.488149816 0.439334835
## [13] 0.395401351 0.355861216 0.320275094 0.288247585 0.259422826 0.233480544
## [19] 0.210132489 0.189119240 0.170207316 0.153186585 0.137867926 0.124081134
## [25] 0.111673020 0.100505718 0.090455146 0.081409632 0.073268669 0.065941802
## [31] 0.059347622 0.053412859 0.048071573 0.043264416 0.038937975 0.035044177
## [37] 0.031539759 0.028385783 0.025547205 0.022992485 0.020693236 0.018623913
## [43] 0.016761521 0.015085369 0.013576832 0.012219149 0.010997234 0.009897511
## [49] 0.008907760 0.008016984
plot(ARMAtoMA(ar=.9, ma=.5, 50)) # for a graph

3.3 Autocorrelation and Partial Autocorrelation

Example 3.16 The PACF of an AR(p)

ACF = ARMAacf(ar=c(1.5,-.75), ma=0, 24)[-1]
PACF = ARMAacf(ar=c(1.5,-.75), ma=0, 24, pacf=TRUE)
par(mfrow=c(1,2))
plot(ACF, type="h", xlab="lag", ylim=c(-.8,1)); abline(h=0)
plot(PACF, type="h", xlab="lag", ylim=c(-.8,1)); abline(h=0)

Example 3.18: Preliminary Analysis of the Recruitment Series

Below shows the ACF and PACF for the recruitment series. These two are consistent with an AR(2) model: the ACF tails off and the PACF essentially dies after 2 (although there are a few slightly significant ones down the line). They run the regression for AR(2) for \[x_t = \phi_0 + \phi_1 x_{t-1} + \phi_2 x_{t-2} + w_t \] Estimates are below.

library(astsa)
acf2(rec, 48)

##      [,1]  [,2]  [,3]  [,4] [,5]  [,6]  [,7] [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.92  0.78  0.63  0.48 0.36  0.26  0.18 0.13 0.10  0.08  0.06  0.03 -0.04
## PACF 0.92 -0.44 -0.05 -0.02 0.07 -0.03 -0.03 0.04 0.05 -0.02 -0.06 -0.14 -0.15
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.11 -0.19 -0.24 -0.27 -0.27 -0.24 -0.19 -0.11 -0.03  0.03  0.07  0.06
## PACF -0.05  0.05  0.01  0.01  0.02  0.08  0.11  0.03 -0.03 -0.01 -0.07 -0.12
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.02 -0.01 -0.05 -0.09 -0.11 -0.12 -0.10 -0.05  0.02  0.09  0.12  0.11
## PACF -0.03  0.05 -0.08 -0.04 -0.03  0.06  0.05  0.15  0.09 -0.04 -0.10 -0.09
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF   0.06  0.01 -0.02 -0.03 -0.03 -0.02  0.01  0.06  0.11  0.17  0.20
## PACF -0.02  0.05  0.08 -0.02 -0.01 -0.02  0.05  0.00  0.05  0.08 -0.04
# will produce values and a graphic
(regr = ar.ols(rec, order=2, demean=FALSE, intercept=TRUE))
## 
## Call:
## ar.ols(x = rec, order.max = 2, demean = FALSE, intercept = TRUE)
## 
## Coefficients:
##      1       2  
##  1.353  -0.462  
## 
## Intercept: 6.755 (1.117) 
## 
## Order selected 2  sigma^2 estimated as  90.66
regr$asy.se.coef # standard errors of the estimates
## $x.mean
## [1] 1.116797
## 
## $ar
## [1] 0.04204102 0.04213343

3.4 Forecasting

Assume throughout this section that \(\{x_t\}\) is stationary and that the model parameters are known.

Example 3.24 Forecasting An ARMA(1,1) Series

This is an excellent example. It shows how all the pieces are coming together. The model has \(x_{n+1} = \phi x_n + w_{n+1} + \theta w_n\). So, \[\tilde{x}_{n+1}^n = \phi x_n + 0 + \theta \tilde{w}_n^n \] \[\tilde{x}_{n+m}^n = \phi \tilde{x}^n_{n+m-1} \text{ for } m\ge 2\]

So, the AR(1) part perpetuates into the forecasts forever. The MA(q) part is no longer explicitly inlucded after step (q) although the calculatable values of the white noise up to time \(n\) are incorporated into all forecasts through recursion, with exponential die off in the old terms because of the geometric term on the AR(p) process.

To calculate the historical forecasts of white noise terms, just use \(w_t = x_t - \phi x_{t-1} - \theta w_{t-1}\) for \(t = 1, \dots, n\) and initial conditions \(\tilde{w}_0^n = 0\) and \(x_0 = 0\). Iterate the errors forward in time so that \[ \tilde{w}_t^n = x_t - \phi x_{t-1} - \theta \tilde{w}_{t-1}^n, \text{ } t = 1, \dots, n\]. Calculate the forecast variance using infinite MA representation of the process; i.e. the variance is \[P_{n+m}^n := E \left [ (x_{n+m} - \tilde{x}_{n+m})^2 \right ] = \sigma_w^2 \sum_{j=0}^{m-1} \psi_j^2\] when \(x_t = \sum_{j = 0} ^\infty \psi_j w_{t-j} = \psi(B)w_t\) is causal representation of \(x_t\) process. For an ARMA(1,1) process, we know that the \(\psi\)-weights satisfy \(\psi_j = (\phi + \theta) \phi^{j-1}\) for all \(j\ge 1\). So, \[P_{n+m}^n = \sigma_w^2 \left[ 1 + (\phi + \theta)^2 \sum_{j=1}^{m-1} \phi^{2(j-1)} \right ] = \sigma_w^2 \left [ 1 + \frac{(\phi + \theta)^2(1 - \phi^{2(m-1)})}{1 -\phi^2}\right ] \] Recall that

Example 3.25 Forecasting the Recruitment Series

Fit an AR(2) model (so don’t have to worry about MA terms on the back). The AR model is \(x_t = 6.74 + 1.35 x_{t-1} - .46 x_{t-2} + w_t\) for \(t = 3, 4, ..., 453\). Therefore, \[\tilde{x}_{n+m}^n = \begin{cases} 6.74 + 1.35 x_{n + m -1}^n - .46 \tilde{x}_{n+m-2}^n \text{ if } m > 0\\ x_{n+m} \text{ if } -n < m \le 0 \end{cases}\] We have \(\hat{\sigma}_w^2 = 89.72\) and for an AR(2) $ \[\begin{cases} \psi_0 = 1 \\ \psi_1 = \phi_1 \\ \psi_j = \theta_1 \psi_{j-1} + \phi_2 \psi_{j-2} \text{ for } j \ge 2\end{cases}\]

$ So since \(P_{n+m^n = \sigma_w^2 \sum_{j=0}^{m-1} \psi_j^2\) we have

library(pacman)
regr = ar.ols(rec, order=2, demean=FALSE, intercept=TRUE)
fore = predict(regr, n.ahead=24)
ts.plot(rec, fore$pred, col=1:2, xlim=c(1980,1990), ylab="Recruitment")
U = fore$pred+fore$se; L = fore$pred-fore$se
xx = c(time(U), rev(time(U))); yy = c(L, rev(U))
polygon(xx, yy, border = 8, col = gray(.6, alpha = .2))
lines(fore$pred, type="p", col=2)

Example 3.26 Backcasting an ARMA(1,1)

Note, backcasting can be done by relabeling the series \(\{x_t\}^n\) to \(\{x_{n-t+1}\}^n\).

\[x_t = \phi x_{t-1} + \theta w_{t-1} + w_t\] Call this the forward model.The process can equivalentlty be written by the backward model \[x_t = \phi x_{t+1} + \theta v_{t+1} + v_t \] where \(v_t\) is a stationary white noise process (they shouldn’t be the same \(\phi\) and \(\theta\)). We write \[x_t = \sum_{j=0}^\infty \psi_j v_{t+j} \] where \(\psi_0=1\). So \(x_t\) is uncorrelated with \(\{v_{t-1}, v_{t-2}, \dots\}\). (Hmm… so, yes. it is very important that we think of it with this different model, because \(x_t\) is correlated with the \(w_{t-1}, w_{t-2}, \dots\)). Given data \(\{x_1, x_2, \dots, x_n \}\) put \(v_n^n = E(v_n|x_1, \dots, x_n)\) and then iterate backward. Put \(\tilde{v}_n^n = 0\) as an initial approximation and then generate the errors backward \[\tilde{v}_t^n = x_t - \phi x_{t+1} - \theta \tilde{v}_{t+1}^n \text{ } t = (n-1), (n-2), \dots, 1\] Then \[\tilde{x}_0^n = \phi x_1 + \theta \tilde{v}_1^n + \tilde{v}_0^n = \phi x_1 + \theta \tilde{v}_1^n\] because \(\tilde{v}_t^n=0\) for \(t\le0\) (i.e. our best guess for past white noise is 0 when backcasting). Then \(\tilde{x}_{1-m}^n = \phi \tilde{x}_{2-m}^n\) for \(m = 2,3, \dots\)

All we have to do with R is reverse the data and predict. the rev function does that for us. We run it once before the analysis and once after!

set.seed(90210)
x= arima.sim(list(order = c(1,0,1), ar =.9, ma=.5), n = 100)
xr= rev(x) # xr is the reversed data *only difference with forecasting*
pxr= predict(arima(xr, order=c(1,0,1)), 10)# predict the reversed data
pxrp = rev(pxr$pred) # reorder the predictors (for plotting)
pxrse = rev(pxr$se) #reordering the se for forecast interval in plot
nx= ts(c(pxrp, x), start=-9) # attach the backcasts to the data
plot(nx, ylab=expression(X[~t]), main='Backcasting')
U = nx[1:10] + pxrse; L = nx[1:10] - pxrse
xx = c(-9:0, 0:-9); yy = c(L, rev(U))
polygon(xx, yy, border = 8, col = gray(0.6, alpha = 0.2))
lines(-9:0, nx[1:10], col=2, type='o')

3.5 Estimation

Start with a causal and invertible Gaussian ARMA(p,q) process where (initially) p and q are assumed known. Goal is to estimate the coefficients on the series.

Example 3.28 Yule-Walker Estimation of the Recruitment Series

Note that the function is ar.yw and the order is 2, because fit an AR(2) model using Yule-Walker (i.e. Method of Moments) coefficients. Note that these coefficients are nearly identical to the values in Example 3.18, where ran OLS. This is because AR(p) models are linear models and the Yule-Walker estimator is essentially least squares estimators. Won’t work as well for MA or ARMA models.

rec.yw = ar.yw(rec, order=2)
rec.yw$x.mean
## [1] 62.17732
# = 62.26 (mean estimate)
rec.yw$ar
## [1]  1.3313857 -0.4441262
# = 1.33, -.44 (coefficient estimates)
sqrt(diag(rec.yw$asy.var.coef)) # = .04, .04 (standard errors)
## [1] 0.04252058 0.04252058
rec.yw$var.pred # = 94.80 (error variance estimate)
## [1] 95.90749
rec.pr = predict(rec.yw, n.ahead=24)
ts.plot(rec, rec.pr$pred, col=1:2)
lines(rec.pr$pred + rec.pr$se, col=4, lty=2)
lines(rec.pr$pred - rec.pr$se, col=4, lty=2)

Example 3.29 Method of Moments Estimation for an MA(1)

Even though \(|\rho(1)| \lt 1/2\) for an invertible estimator, it may be that \(|\hat{\rho}|\gt 1/2\) because its an estimator. See this belowe.

set.seed(2)
ma1 = arima.sim(list(order = c(0,0,1), ma = 0.9), n = 50)
acf(ma1, plot=FALSE)[1] # = .507 (lag 1 sample ACF)
## 
## Autocorrelations of series 'ma1', by lag
## 
##     1 
## 0.507

Example 3.31 MLE for the Recruitment Series

Compare with Example 3.18 where fit with OLS and Example 3.28 where fit with Yule-Walker (method of moments).

rec.mle = ar.mle(rec, order=2)
rec.mle$x.mean # 62.26
## [1] 62.1759
rec.mle$ar # 1.35, -.46
## [1]  1.3510750 -0.4610124
sqrt(diag(rec.mle$asy.var.coef))
## [1] 0.04129499 0.04129499
rec.mle$var.pred #89.34
## [1] 90.45839

Example 3.33 Fitting the Glacial Varve Series

Note that the ACF looks like only first one is significant and the PACF telescope off. This suggests MA(1) may be reasonable.

Question: Are ACF and PACF plots reasonable on nonstationary data? Cause the last two presentations I watched showed ACF plots but it wasn’t clear that the data was stationary before hand.

Note that these plots were done on pre-transformed data. I.e. The data are transformed into \[y_t = \nabla log(x_t)\] since the \(\{y_t\}\) are stationary but the \(x_t\) aren’t.

Below

x = diff(log(varve))
# Evaluate Sc on a Grid
c(0) -> w -> z
c() -> Sc -> Sz -> Szw
num = length(x)
th = seq(-.3,-.94,-.01)
for (p in 1:length(th)){
  for (i in 2:num){ 
    w[i] = x[i]-th[p]*w[i-1] 
  }
  Sc[p] = sum(w^2)
}
plot(th, Sc, type="l", ylab=expression(S[c](theta)), 
     xlab=expression(theta), lwd=2, main = "Iterations on Gauss Newton Until Estimator (of MA(1) coefficent) Convergence")
# Gauss-Newton Estimation
r = acf(x, lag=1, plot=FALSE)$acf[-1]
rstart = (1-sqrt(1-4*(r^2)))/(2*r)
# from (3.105)
c(0) -> w -> z
c() -> Sc -> Sz -> Szw -> para
niter = 12
para[1] = rstart
for (p in 1:niter){
  for (i in 2:num){ 
    w[i] = x[i]-para[p]*w[i-1]
    z[i] = w[i-1]-para[p]*z[i-1]
  }
  Sc[p] = sum(w^2)
  Sz[p] = sum(z^2)
  Szw[p] = sum(z*w)
  para[p+1] = para[p] + Szw[p]/Sz[p] 
}
round(cbind(iteration=0:(niter-1), thetahat=para[1:niter] , Sc , Sz ), 3)
##       iteration thetahat      Sc      Sz
##  [1,]         0   -0.495 158.739 171.240
##  [2,]         1   -0.668 150.747 235.266
##  [3,]         2   -0.733 149.264 300.562
##  [4,]         3   -0.756 149.031 336.823
##  [5,]         4   -0.766 148.990 354.173
##  [6,]         5   -0.769 148.982 362.167
##  [7,]         6   -0.771 148.980 365.801
##  [8,]         7   -0.772 148.980 367.446
##  [9,]         8   -0.772 148.980 368.188
## [10,]         9   -0.772 148.980 368.522
## [11,]        10   -0.773 148.980 368.673
## [12,]        11   -0.773 148.980 368.741
abline(v = para[1:12], lty=2)
points(para[1:12], Sc[1:12], pch=16)

Example 3.36 Bootstrapping an AR(1)

Model is \(x_t = \mu + \phi(x_{t-1} - \mu) + w_t\) where \(\mu = 50\), \(\phi = .95\) and \(w_t\) are iid double exponential with location 0 and scale parameter \(\beta = 2\). Simulate 100 points from the data below. It looks like the data is nonsationary because of the errors, but in actuallity, the data are stationary just with a funky unobservable noise process.

set.seed(101010)
e = rexp(150, rate=.5); u = runif(150,-1,1); de = e*sign(u)
dex = 50 + arima.sim(n=100, list(ar=.95), innov=de, n.start=50)
plot.ts(dex, type='o', ylab=expression(X[~t]))

fit = ar.yw(dex, order=1)
round(cbind(fit$x.mean, fit$ar, fit$var.pred), 2)
##       [,1] [,2] [,3]
## [1,] 45.25 0.96 7.88

Obtain the Yule-Walker estimate. (Recall that Yule-Walker is efficient for AR(1) processes, so can do that. Otherwise should go with MLE? Or, if we just care about the value and not the confidence intervals, I guess it doesn’t really matter what we fit?)

Creating the sample distribution and compare it to the asymptotic distribution. The asymptotic distribution is a poor fit. However, the bootstrap distribution does really great.

The bootstrap resampling is done over the “innovations;” that is, the difference between the one-step ahead predictions and the true values. So you resample the innovations to generate the next data points, given your original estimates. Then you re-estimate your coefficients and the variance with each step.

b/c \[x_t = x_t^{t-1} + \epsilon_t = \mu + \phi(x_{t-1} - \mu) + \epsilon_t\] where innovations \(\epsilon_t\) are defined by \[\epsilon_t := x_t - x_{t}^{t-1} \] and \(x_t^{t-1}\) are the one-step ahead predictions given data \(x_1, \dots, x_{t-1}\)

set.seed(111)
phi.yw = rep(NA, 1000)
for (i in 1:1000){
  e = rexp(150, rate=.5); u = runif(150,-1,1); de = e*sign(u)
  x = 50 + arima.sim(n=100,list(ar=.95), innov=de, n.start=50)
  phi.yw[i] = ar.yw(x, order=1)$ar
}

set.seed(666) #not that 666
fit = ar.yw(dex, order=1) #assumes the data were retained
m = fit$x.mean # estimate of mean
phi = fit$ar #estimate of phi
nboot = 500 #number of bootstrap replicates
resids = fit$resid[-1] # the 99 innovations

x.star = dex # initialize x*
phi.star.yw = rep(NA, nboot)
# Bootstrap
for (i in 1:nboot) {
  resid.star = sample(resids, replace=TRUE)
  for (t in 1:99){ 
    x.star[t+1] = m + phi*(x.star[t]-m) + resid.star[t] 
  }
  phi.star.yw[i] = ar.yw(x.star, order=1)$ar
}

# Picture
culer = rgb(.5,.7,1,.5)
hist(phi.star.yw, 15, main="", prob=TRUE, xlim=c(.65,1.05), ylim=c(0,14),
  col=culer, xlab=expression(hat(phi)))
lines(density(phi.yw, bw=.02), lwd=2) # from previous simulation
u = seq(.75, 1.1, by=.001) # normal approximation
lines(u, dnorm(u, mean=.96, sd=.03), lty=2, lwd=2)
legend(.65, 14, legend=c('true distribution', 'bootstrap distribution',
  'normal approximation'), bty='n', lty=c(1,0,2), lwd=c(2,0,2),
  col=1, pch=c(NA,22,NA), pt.bg=c(NA,culer,NA), pt.cex=2.5)

3.6 Integrated Models for Nonstationary Data

ARIMA models are nonstationary. Both the theoretical and computational aspects of the problem are best handled via state-space models. Discuss state-space models in Chapter 6.

Example 3.38 IMA(1,1) and EWMA

EWMA = exponentially weighted moving averages. IMA(1,1) = ARIMA(0,1,1) is a once-integrated MA(1) process.

\(x_t = x_{t-1} + w_t - \lambda w_{t-1}\)

Can show for this process, truncated forecasts are \[\tilde{x}_{n+1}^n = (1 - \lambda) x_n + \lambda \tilde{x}_n^{n-1},\text{ } n \ge 1\] which is just a simple linear combination of yesterday’s prediction and yesterday’s true value.

This is very easy to forecast with. Some make it too easy by not verifying or justifying the process being IMA(1,1) when applying it and choosing \(\lambda\) arbitrarily, not estimating it. (e.g. calibrating?) Lambda is called the smoothing paramter, the larger lambda is (up to 1), the smoother the function is

?arima
?predict.Arima #sarima and sarima.for are wrappers for these R scripts

set.seed(666)
x = arima.sim(list(order = c(0,1,1), ma = -0.8), n = 100)
(x.ima = HoltWinters(x, beta=FALSE, gamma=FALSE)) # α below is 1 − λ
## Holt-Winters exponential smoothing without trend and without seasonal component.
## 
## Call:
## HoltWinters(x = x, beta = FALSE, gamma = FALSE)
## 
## Smoothing parameters:
##  alpha: 0.1663072
##  beta : FALSE
##  gamma: FALSE
## 
## Coefficients:
##        [,1]
## a -2.241533
#Smoothing parameter: alpha:
# 0.1663072
plot(x.ima)

3.7 Building ARIMA Models

The basic steps are as follows 1. Plot the data - create a time plot and inspect it for anomalies - if variance grows with time, use variance stabilizing transformations - Box-Cox class of power transformations can be employed - log change is recommended for small percentage changes. Will probably want to try this one for my data 2. Possibly transform the data - see above 3. Identify the dependence orders of the model - want to identify a. order of differencing d - this should look at first - time plot should suggest whether any differencing is needed - don’t overdifference, as it may introduce dependence where non existed - e.g. \(x_t = w_t\) is serially uncorrelated but \(\nabla x_t = w_t - x_{t-1}\) is MA(1) - sample ACF plot can help with differencing - if the sample ACF does not decay to zero fast as h increases b. moving average order q (looking at differenced out series \(\nabla^d x_t\)) - use table 3.1 as your guide: - If ACF cuts off, can guess its MA process c. autoregressive order p (looking at differenced out series \(\nabla^d x_t\) ) - use table 3.1 as your guide - if PACF cuts off, it is AR process. - This should give you a few preliminary values of p, d and q and allow you to start estimating the parameters. 4. Estimate parameters 5. Diagnostics 6. Model Choice

Example 3.39 Analysis of GNP Data **This example is highly relevant for my data as it is likely to exhibit many of the same patterns as mine… except it is seasonally adjusted.

  • Quarterly GNP from 1947(1) to 2002(3)

  • Data from fed erserve Bank of St. Louis.

  • call the data \(y_t\).

  • call the growth rate \(x_t = \nabla log(y_t)\)

  • the growth rate appears to be stable.

  • Looking at ACF and PACF, seems ACF is cutting off at lag 2

  • PACF is tailing off

  • therefore an MA(2) process for \(x_t\)

  • That is, \(log(y_t)\) follows an ARIMA(0,1,2)

  • alternative story is that the ACF is tailing off and PaCF is cutting off at lag 1. So, ARIMA(1,1,0) for \(log(y_t)\)

    • when you look at the pictures, both really are plausible. The answer isn’t clear cut at all

  • MA(2): \[\hat{x}_t = .008 + .303 \hat{w}_{t-1} + .204 \hat{w}_{t-2} + \hat{w}_t\]

Note that the constant is nonzero and highly significant; this is worth noting as some computer packages do not fit a constant in a differenced model!!! (which would appear to be incorrect). The constant captures the “drift”. Here, it is around 1 percent; that is, the average quarterly growth rate of gdp is around 1%

  • AR(1): \[.008 (1 - .347) + .347 \hat{x}_{t-1} + \hat{w}_t \]

Note that (ignoring the constant term) if your tried to expand the process \(x_t = .35x_{t-1} + w_t\) into its infinite invertible form, you get \(x_t \approx .35w_{t-1} + .12 w_{t-2} + w_t\) which is pretty close to the (constantless) version of the stimated (with later terms relatively closer to 0.)

plot(gnp)

acf2(gnp, 50)

##      [,1] [,2]  [,3] [,4] [,5]  [,6]  [,7]  [,8]  [,9] [,10] [,11] [,12] [,13]
## ACF  0.99 0.97  0.96 0.94 0.93  0.91  0.90  0.88  0.87  0.85  0.83  0.82  0.80
## PACF 0.99 0.00 -0.02 0.00 0.00 -0.02 -0.02 -0.02 -0.01 -0.02  0.00 -0.01  0.01
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF   0.79  0.77  0.76  0.74  0.73  0.72   0.7  0.69  0.68  0.66  0.65  0.64
## PACF  0.00  0.00  0.00  0.01  0.00 -0.01   0.0 -0.01 -0.01  0.00  0.00  0.00
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.62  0.61  0.60  0.59  0.57  0.56  0.55  0.54  0.52  0.51   0.5  0.49
## PACF -0.01  0.00 -0.01 -0.01 -0.01 -0.01 -0.01  0.00 -0.01  0.00   0.0  0.00
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48] [,49]
## ACF   0.48  0.47  0.45  0.44  0.43  0.42  0.41  0.40  0.38  0.37  0.36  0.35
## PACF -0.01 -0.01 -0.01  0.00 -0.01 -0.01 -0.01 -0.01 -0.01 -0.01 -0.02 -0.02
##      [,50]
## ACF   0.33
## PACF -0.01
gnpgr = diff(log(gnp)) # growth rate
plot(gnpgr)

acf2(gnpgr, 24)

##      [,1] [,2]  [,3]  [,4]  [,5]  [,6]  [,7]  [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.35 0.19 -0.01 -0.12 -0.17 -0.11 -0.09 -0.04 0.04  0.05  0.03 -0.12 -0.13
## PACF 0.35 0.08 -0.11 -0.12 -0.09  0.01 -0.03 -0.02 0.05  0.01 -0.03 -0.17 -0.06
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24]
## ACF  -0.10 -0.11  0.05  0.07  0.10  0.06  0.07 -0.09 -0.05 -0.10 -0.05
## PACF  0.02 -0.06  0.10  0.00  0.02 -0.04  0.01 -0.11  0.03 -0.03  0.00
sarima(gnpgr, 1, 0, 0) # AR(1)
## initial  value -4.589567 
## iter   2 value -4.654150
## iter   3 value -4.654150
## iter   4 value -4.654151
## iter   4 value -4.654151
## iter   4 value -4.654151
## final  value -4.654151 
## converged
## initial  value -4.655919 
## iter   2 value -4.655921
## iter   3 value -4.655922
## iter   4 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## final  value -4.655922 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xmean, include.mean = FALSE, transform.pars = trans, 
##     fixed = fixed, optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1   xmean
##       0.3467  0.0083
## s.e.  0.0627  0.0010
## 
## sigma^2 estimated as 9.03e-05:  log likelihood = 718.61,  aic = -1431.22
## 
## $degrees_of_freedom
## [1] 220
## 
## $ttable
##       Estimate     SE t.value p.value
## ar1     0.3467 0.0627  5.5255       0
## xmean   0.0083 0.0010  8.5398       0
## 
## $AIC
## [1] -6.44694
## 
## $AICc
## [1] -6.446693
## 
## $BIC
## [1] -6.400958
sarima(gnpgr, 0, 0, 2) # MA(2)
## initial  value -4.591629 
## iter   2 value -4.661095
## iter   3 value -4.662220
## iter   4 value -4.662243
## iter   5 value -4.662243
## iter   6 value -4.662243
## iter   6 value -4.662243
## iter   6 value -4.662243
## final  value -4.662243 
## converged
## initial  value -4.662022 
## iter   2 value -4.662023
## iter   2 value -4.662023
## iter   2 value -4.662023
## final  value -4.662023 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xmean, include.mean = FALSE, transform.pars = trans, 
##     fixed = fixed, optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ma1     ma2   xmean
##       0.3028  0.2035  0.0083
## s.e.  0.0654  0.0644  0.0010
## 
## sigma^2 estimated as 8.919e-05:  log likelihood = 719.96,  aic = -1431.93
## 
## $degrees_of_freedom
## [1] 219
## 
## $ttable
##       Estimate     SE t.value p.value
## ma1     0.3028 0.0654  4.6272  0.0000
## ma2     0.2035 0.0644  3.1594  0.0018
## xmean   0.0083 0.0010  8.7178  0.0000
## 
## $AIC
## [1] -6.450133
## 
## $AICc
## [1] -6.449637
## 
## $BIC
## [1] -6.388823
ARMAtoMA(ar=.35, ma=0, 10) # prints psi-weights
##  [1] 3.500000e-01 1.225000e-01 4.287500e-02 1.500625e-02 5.252187e-03
##  [6] 1.838266e-03 6.433930e-04 2.251875e-04 7.881564e-05 2.758547e-05
# authors mention a script called tsdiag that plots diagnostics for ARIMA objects, but say its buggy and don't recommend using it

The authors give a number of excellent diagnostic tools with the example. The diagnostic tools are very easy to check, too.

They recommend looking at: 1. Standardized innovations (a.k.a. normalized residuals). If fits well, errors should look iid N(0,1). Note, it is not enough the errors are uncorrelated Could be uncorrelated but still highly dependent, as discussed with GARCH in chapter 5. 2. Check Marginal normality by making a QQ plot. 3. Test for Randomness. a. Runs test b. Look at sample autocorrelation of residuals i. sample autocorrelatoin should be iid normal with variance 1/n. Plot autocorrelation vs h and bars of plus or minus \(2\sqrt{n}\) ii. Can use the Ljung-Box-Pierce Q-Statistic. Looks at the sum of squared autocoviarates. Should be distributed chi-squared if model right. The diagnostic tools looks for the sum up to H = 3, 4, .., 20. If any of the H values have significant p-values (i.e. very small), its a concern. Actually, for this one it looks like \(H=5\) is small, but not below the dotted blue line. So, fine.

Example 3.40 Diagnostics for GNP Growth Rate Example

See above.

*Example 3.41 Diagnostics of the Glacial Varve Series

sarima(log(varve), 0, 1, 1, no.constant=TRUE) 
## initial  value -0.551778 
## iter   2 value -0.671626
## iter   3 value -0.705973
## iter   4 value -0.707314
## iter   5 value -0.722372
## iter   6 value -0.722738
## iter   7 value -0.723187
## iter   8 value -0.723194
## iter   9 value -0.723195
## iter   9 value -0.723195
## iter   9 value -0.723195
## final  value -0.723195 
## converged
## initial  value -0.722700 
## iter   2 value -0.722702
## iter   3 value -0.722702
## iter   3 value -0.722702
## iter   3 value -0.722702
## final  value -0.722702 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), include.mean = !no.constant, transform.pars = trans, fixed = fixed, 
##     optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##           ma1
##       -0.7705
## s.e.   0.0341
## 
## sigma^2 estimated as 0.2353:  log likelihood = -440.72,  aic = 885.44
## 
## $degrees_of_freedom
## [1] 632
## 
## $ttable
##     Estimate     SE  t.value p.value
## ma1  -0.7705 0.0341 -22.6161       0
## 
## $AIC
## [1] 1.398792
## 
## $AICc
## [1] 1.398802
## 
## $BIC
## [1] 1.412853
 # ARIMA(0,1,1) has problems
sarima(log(varve), 1, 1, 1, no.constant=TRUE)
## initial  value -0.550992 
## iter   2 value -0.648952
## iter   3 value -0.676952
## iter   4 value -0.699136
## iter   5 value -0.724481
## iter   6 value -0.726964
## iter   7 value -0.734257
## iter   8 value -0.735999
## iter   9 value -0.737045
## iter  10 value -0.737381
## iter  11 value -0.737469
## iter  12 value -0.737473
## iter  13 value -0.737473
## iter  14 value -0.737473
## iter  14 value -0.737473
## iter  14 value -0.737473
## final  value -0.737473 
## converged
## initial  value -0.737355 
## iter   2 value -0.737361
## iter   3 value -0.737362
## iter   4 value -0.737363
## iter   5 value -0.737363
## iter   5 value -0.737363
## iter   5 value -0.737363
## final  value -0.737363 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), include.mean = !no.constant, transform.pars = trans, fixed = fixed, 
##     optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1      ma1
##       0.2330  -0.8858
## s.e.  0.0518   0.0292
## 
## sigma^2 estimated as 0.2284:  log likelihood = -431.44,  aic = 868.88
## 
## $degrees_of_freedom
## [1] 631
## 
## $ttable
##     Estimate     SE  t.value p.value
## ar1   0.2330 0.0518   4.4994       0
## ma1  -0.8858 0.0292 -30.3861       0
## 
## $AIC
## [1] 1.37263
## 
## $AICc
## [1] 1.372661
## 
## $BIC
## [1] 1.393723
 # ARIMA(1,1,1) looks much better

# note that if remove no.constant=TRUE, the constant is not significant. Thats why didn't include it. Even though they previously complained a lot about some analysts leaving them out when the constants are significant.

We can see the second model fit very well. The first model fails the Ljung-Box statistic tests, though! The autocorrelatoin function is significant at every single sum of lags \(H\).

Example 3.42 Ridiculous Answer with extreme overfitting

I mean, they baked it to look really bad. Whenever you are including polynomials, its gonna have weird extrapolatoin properties. Fit \[x_t = \beta_0 + \beta_1t + \beta_2 t + \cdots + \beta_8 t^8 + w_t\]

Fit 8 points of census data from 1910 to 1990. Plots populatino to plummet after 1990.

Reminds us of AIC and BIC for parsimonious model selection, to not overfit.

Example 3.43 Model Choice for the U.S. GNP Series

Compare AIC, AICc and BIC of AR(1) and MA(2) fit on US GNP data. More negative is better

#Remembermore negative is better. THe numbers are really close though.
sarima(gnpgr, 1, 0, 0) # AR(1)
## initial  value -4.589567 
## iter   2 value -4.654150
## iter   3 value -4.654150
## iter   4 value -4.654151
## iter   4 value -4.654151
## iter   4 value -4.654151
## final  value -4.654151 
## converged
## initial  value -4.655919 
## iter   2 value -4.655921
## iter   3 value -4.655922
## iter   4 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## final  value -4.655922 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xmean, include.mean = FALSE, transform.pars = trans, 
##     fixed = fixed, optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1   xmean
##       0.3467  0.0083
## s.e.  0.0627  0.0010
## 
## sigma^2 estimated as 9.03e-05:  log likelihood = 718.61,  aic = -1431.22
## 
## $degrees_of_freedom
## [1] 220
## 
## $ttable
##       Estimate     SE t.value p.value
## ar1     0.3467 0.0627  5.5255       0
## xmean   0.0083 0.0010  8.5398       0
## 
## $AIC
## [1] -6.44694
## 
## $AICc
## [1] -6.446693
## 
## $BIC
## [1] -6.400958
#$AIC: -8.294403 $AICc: -8.284898 $BIC: -9.263748
sarima(gnpgr, 0, 0,2) # MA(2)
## initial  value -4.591629 
## iter   2 value -4.661095
## iter   3 value -4.662220
## iter   4 value -4.662243
## iter   5 value -4.662243
## iter   6 value -4.662243
## iter   6 value -4.662243
## iter   6 value -4.662243
## final  value -4.662243 
## converged
## initial  value -4.662022 
## iter   2 value -4.662023
## iter   2 value -4.662023
## iter   2 value -4.662023
## final  value -4.662023 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xmean, include.mean = FALSE, transform.pars = trans, 
##     fixed = fixed, optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ma1     ma2   xmean
##       0.3028  0.2035  0.0083
## s.e.  0.0654  0.0644  0.0010
## 
## sigma^2 estimated as 8.919e-05:  log likelihood = 719.96,  aic = -1431.93
## 
## $degrees_of_freedom
## [1] 219
## 
## $ttable
##       Estimate     SE t.value p.value
## ma1     0.3028 0.0654  4.6272  0.0000
## ma2     0.2035 0.0644  3.1594  0.0018
## xmean   0.0083 0.0010  8.7178  0.0000
## 
## $AIC
## [1] -6.450133
## 
## $AICc
## [1] -6.449637
## 
## $BIC
## [1] -6.388823
# $AIC: -8.297693 $AICc: -8.287854 $BIC: -9.251711

Since both models work, retain the AR(1)! Pure AR are easier to work with than MA processes!.

3.8 Regression with Autocorrelated Errors

The basic idea of this section is how to deal with errors that don’t look like white noise. The key insight is that we can solve it through a process that is analogous to weighted least squares. Essentially, if \[y_t = \sum_{j=1}^r \beta_j z_{jt} + x_t\] where \(x_t\) is ARMA(p,q)

Note this is kind of how you might approach this if you were a scientist and were just running a regression. As a diagnostic, you check how the Errors look. You discover the PACF and ACF suggest a time series process to errors. So, you fit the error time series and then adjust your regression estimates.

Bigger Note: Both the examples have AR(2) residuals. That is, all of the examples could have originally been fit as some kind of MA(2) process! Because if the residuals are AR(2) you could replace your regression model with one of MA(2), right? So, rather than running the weighted least squares regression, just run an MA(2) regression? It seems that is valid. **Indeed, this is exactly what the authors end up

Note, this is not a model of ARMA \(y_t\) and ARMA \(x_t\) but rather a relationship of linear \(y_t\) dependence on \(z_t\) but an ARMA noise process!. Could you also adapt to an ARMA \(y_t\) model process? I would think you should be able to. Indeed, it might be reasonable that, if you can’t tell if its an AR or an MA process, you start with the AR and look at the residuals and see if there is still some MA to them.

Example 3.44 Mortality Temperature and Pollution

Model is \[M_t = \beta_1 + \beta_2 t + \beta_3 T_t + \beta_4 T_t^2 + \beta_5 P_t + x_t \] where \(P_t\) is pressure, \(T_t\) is temperature and \(M_t\) is cardiovascular mortality. Exactly as discussesd in this section, the model is a linear model but the residuals are not iid Gausian. Rather, the errors are some time series. Sample ACF and PACF are shown in Figure 3.19. The results suggest an AR(2) model for the residuals.

Fit \[x_t = \phi x_{t-1} + \phi_2 x_{t-2} + w_t \] with sarima function. The diagnostic tests on residuals look fine. Then we can run the weighted regression as discussed (although they don’t give the code to run the final weighted regression!).

The weighted regression would require transforming \(y_t\) into \(y_t^\star = y_t - \phi_1 y_{t-1} - \phi_2 y_{t-2}\) and do that to all the other terms too (including the time constant? I guess so. Yes! if wanted the same \(\beta\) for the constant, would need it!) So the constant would become \(1 - \phi_1 - \phi_2\) and etc. After transformed all the variables to their new forms, then run the OLS again and you can interpret the regression coefficients as if you had run the same original regression! pretty cool.

The author takes a nice shortcut from running the weighted regression, however, and simply runs an MA(2) model on the data! Nice. Exactly as I had reasoned would work at the start of this chapter. The sarima code both runs the new MA(2) regressoin and produces new diagnostics.

trend = time(cmort); temp = tempr - mean(tempr); temp2 = temp^2
summary(fit <- lm(cmort~trend + temp + temp2 + part, na.action=NULL))
## 
## Call:
## lm(formula = cmort ~ trend + temp + temp2 + part, na.action = NULL)
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -19.0760  -4.2153  -0.4878   3.7435  29.2448 
## 
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)    
## (Intercept)  2.831e+03  1.996e+02   14.19  < 2e-16 ***
## trend       -1.396e+00  1.010e-01  -13.82  < 2e-16 ***
## temp        -4.725e-01  3.162e-02  -14.94  < 2e-16 ***
## temp2        2.259e-02  2.827e-03    7.99 9.26e-15 ***
## part         2.554e-01  1.886e-02   13.54  < 2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 6.385 on 503 degrees of freedom
## Multiple R-squared:  0.5954, Adjusted R-squared:  0.5922 
## F-statistic:   185 on 4 and 503 DF,  p-value: < 2.2e-16
acf2(resid(fit), 52) #plots acf and pacf fo residuals

##      [,1] [,2] [,3] [,4]  [,5]  [,6]  [,7]  [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.34 0.44 0.28 0.28  0.16  0.12  0.07  0.01 0.03 -0.05 -0.02  0.00 -0.04
## PACF 0.34 0.36 0.08 0.06 -0.05 -0.05 -0.02 -0.05 0.02 -0.06  0.00  0.06 -0.02
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.02  0.01 -0.05 -0.01 -0.03 -0.06 -0.03 -0.03 -0.05  0.00 -0.02 -0.01
## PACF  0.00  0.04 -0.08  0.00 -0.01 -0.06  0.03  0.02 -0.03  0.05 -0.01  0.00
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF  -0.05  0.03 -0.11 -0.02 -0.10 -0.02 -0.09 -0.03 -0.10 -0.08 -0.10 -0.07
## PACF -0.06  0.06 -0.11  0.00 -0.05  0.05 -0.04  0.04 -0.06 -0.06 -0.05  0.03
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48] [,49]
## ACF  -0.07 -0.05 -0.05 -0.04 -0.03 -0.04  0.05  0.00  0.04  0.08  0.07  0.06
## PACF -0.02  0.02 -0.01  0.00  0.00 -0.01  0.08 -0.01 -0.01  0.08 -0.01 -0.01
##      [,50] [,51] [,52]
## ACF   0.05  0.07  0.02
## PACF -0.03  0.03 -0.04
# implies AR2 ish
sarima(cmort, 2,0,0, xreg=cbind(trend,temp,temp2,part))
## initial  value 1.849900 
## iter   2 value 1.733730
## iter   3 value 1.701063
## iter   4 value 1.682463
## iter   5 value 1.657377
## iter   6 value 1.652444
## iter   7 value 1.641726
## iter   8 value 1.635302
## iter   9 value 1.630848
## iter  10 value 1.629286
## iter  11 value 1.628731
## iter  12 value 1.628646
## iter  13 value 1.628634
## iter  14 value 1.628633
## iter  15 value 1.628632
## iter  16 value 1.628628
## iter  17 value 1.628627
## iter  18 value 1.628627
## iter  19 value 1.628626
## iter  20 value 1.628625
## iter  21 value 1.628622
## iter  22 value 1.628618
## iter  23 value 1.628614
## iter  24 value 1.628612
## iter  25 value 1.628611
## iter  26 value 1.628610
## iter  27 value 1.628610
## iter  28 value 1.628609
## iter  29 value 1.628609
## iter  30 value 1.628608
## iter  31 value 1.628608
## iter  32 value 1.628608
## iter  32 value 1.628608
## iter  32 value 1.628608
## final  value 1.628608 
## converged
## initial  value 1.630401 
## iter   2 value 1.630393
## iter   3 value 1.630382
## iter   4 value 1.630381
## iter   5 value 1.630375
## iter   6 value 1.630370
## iter   7 value 1.630362
## iter   8 value 1.630354
## iter   9 value 1.630349
## iter  10 value 1.630347
## iter  11 value 1.630347
## iter  12 value 1.630347
## iter  13 value 1.630347
## iter  14 value 1.630346
## iter  15 value 1.630346
## iter  16 value 1.630346
## iter  17 value 1.630346
## iter  17 value 1.630346
## iter  17 value 1.630346
## final  value 1.630346 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1     ar2  intercept    trend     temp   temp2    part
##       0.3848  0.4326  3075.1482  -1.5165  -0.0190  0.0154  0.1545
## s.e.  0.0436  0.0400   834.7087   0.4226   0.0495  0.0020  0.0272
## 
## sigma^2 estimated as 26.01:  log likelihood = -1549.04,  aic = 3114.07
## 
## $degrees_of_freedom
## [1] 501
## 
## $ttable
##            Estimate       SE t.value p.value
## ar1          0.3848   0.0436  8.8329  0.0000
## ar2          0.4326   0.0400 10.8062  0.0000
## intercept 3075.1482 834.7087  3.6841  0.0003
## trend       -1.5165   0.4226 -3.5882  0.0004
## temp        -0.0190   0.0495 -0.3837  0.7014
## temp2        0.0154   0.0020  7.6117  0.0000
## part         0.1545   0.0272  5.6803  0.0000
## 
## $AIC
## [1] 6.130066
## 
## $AICc
## [1] 6.130507
## 
## $BIC
## [1] 6.196687

Example 3.45 Regression with Lagged Variables

Fit the model \[R_t = \beta_0 + \beta_1 S_{t-6} + \beta_2 D_{t-6} + \beta_3 D_{t-6}S_{t-6} + w_t \]

where \(R_t\) is recruitment, \(S_t\) is SOI and \(D_t\) is a dummy variable that is 0 if \(S_t < 0\) and 1 otherwise. (Essentially, the dummy is allowing for a level effect from SOI and the SOI term is allowing for a separate slope affect from SOI.) However, residual diagnostics suggest the residuals are not white noise. The sample (P)ACF of the residuals indicates an AR(2) model might be appropriate.

Note again that \(R_t\) is not an ARMA process. The \(w_t\) are an ARMA process. We will fit an AR(2) to the noise. (Although, isn’t it the case that if the \(w_t\) are AR(2), then \(R_t\) is actually an MA(2 ) )

dummy = ifelse(soi<0, 0, 1)
fish = ts.intersect(rec, soiL6=lag(soi,-6), dL6=lag(dummy,-6), dframe=TRUE)
summary(fit <- lm(rec ~soiL6*dL6, data=fish, na.action=NULL))
## 
## Call:
## lm(formula = rec ~ soiL6 * dL6, data = fish, na.action = NULL)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -63.291 -15.821   2.224  15.791  61.788 
## 
## Coefficients:
##             Estimate Std. Error t value Pr(>|t|)    
## (Intercept)   74.479      2.865  25.998  < 2e-16 ***
## soiL6        -15.358      7.401  -2.075   0.0386 *  
## dL6           -1.139      3.711  -0.307   0.7590    
## soiL6:dL6    -51.244      9.523  -5.381  1.2e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 21.84 on 443 degrees of freedom
## Multiple R-squared:  0.4024, Adjusted R-squared:  0.3984 
## F-statistic: 99.43 on 3 and 443 DF,  p-value: < 2.2e-16
attach(fish)
## The following objects are masked from fish (pos = 3):
## 
##     dL6, rec, soiL6
## The following object is masked from package:astsa:
## 
##     rec
plot(resid(fit))

acf2(resid(fit))

##      [,1] [,2]  [,3]  [,4]  [,5]  [,6] [,7]  [,8]  [,9] [,10] [,11] [,12] [,13]
## ACF  0.69 0.62  0.49  0.37  0.24  0.15 0.08  0.00 -0.03 -0.10 -0.13 -0.16 -0.17
## PACF 0.69 0.26 -0.01 -0.08 -0.12 -0.04 0.01 -0.05  0.01 -0.07 -0.05 -0.02 -0.01
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.23 -0.24 -0.23 -0.23 -0.22 -0.17 -0.09 -0.05  0.01  0.05  0.06  0.09
## PACF -0.12 -0.04  0.02 -0.02  0.00  0.03  0.12  0.02 -0.01  0.01 -0.04  0.00
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.07  0.10  0.06  0.02 -0.02 -0.02 -0.02 -0.03 -0.02  0.00  0.01 -0.01
## PACF -0.04  0.06 -0.09 -0.10 -0.05  0.04  0.04 -0.01  0.03  0.04  0.01 -0.04
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF  -0.04 -0.07 -0.05 -0.06 -0.03 -0.02  0.01  0.04  0.04  0.08  0.08
## PACF -0.07 -0.04  0.06  0.01  0.06 -0.02  0.00  0.03 -0.04  0.04 -0.01
# indicates AR(2)
intract = soiL6*dL6
# interaction term
sarima(rec,2,0,0, xreg = cbind(soiL6, dL6, intract))
## initial  value 3.080982 
## iter   2 value 2.921817
## iter   3 value 2.671207
## iter   4 value 2.554389
## iter   5 value 2.404164
## iter   6 value 2.365228
## iter   7 value 2.256092
## iter   8 value 2.240552
## iter   9 value 2.238427
## iter  10 value 2.232931
## iter  11 value 2.232826
## iter  12 value 2.232765
## iter  13 value 2.232755
## iter  14 value 2.232750
## iter  15 value 2.232750
## iter  16 value 2.232749
## iter  17 value 2.232749
## iter  17 value 2.232749
## iter  17 value 2.232749
## final  value 2.232749 
## converged
## initial  value 2.234466 
## iter   2 value 2.234463
## iter   3 value 2.234460
## iter   4 value 2.234460
## iter   5 value 2.234459
## iter   6 value 2.234459
## iter   7 value 2.234458
## iter   8 value 2.234456
## iter   9 value 2.234455
## iter  10 value 2.234454
## iter  11 value 2.234453
## iter  11 value 2.234453
## iter  11 value 2.234453
## final  value 2.234453 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1      ar2  intercept   soiL6      dL6   intract
##       1.3624  -0.4703    64.8028  8.6671  -2.5945  -10.3092
## s.e.  0.0440   0.0444     4.1121  2.2205   0.9535    2.8311
## 
## sigma^2 estimated as 86.78:  log likelihood = -1633.07,  aic = 3280.13
## 
## $degrees_of_freedom
## [1] 441
## 
## $ttable
##           Estimate     SE  t.value p.value
## ar1         1.3624 0.0440  30.9303  0.0000
## ar2        -0.4703 0.0444 -10.5902  0.0000
## intercept  64.8028 4.1121  15.7590  0.0000
## soiL6       8.6671 2.2205   3.9033  0.0001
## dL6        -2.5945 0.9535  -2.7209  0.0068
## intract   -10.3092 2.8311  -3.6415  0.0003
## 
## $AIC
## [1] 7.338104
## 
## $AICc
## [1] 7.338531
## 
## $BIC
## [1] 7.40235

3.9 Multiplicative Seasonal ARIMA (SARIMA) Models

Section very relevant for me!

This is the reason we have been using the (most general) sarima function for our regression! That’s nice; just need to specify what we want and we can recover it!

Example 3.46 A Seasonal AR Series

A first-order seasonal AR series run over months could be written as \[(1 - \Phi B^{12})x_t = w_t\] or \[x_t = \Phi x_{t-12} + w_t\] They simulate 3 years of data from the model with \(\Phi = .9\) and exhibit the theoretical ACF and PACF of the model.

You can see that the PACF correctly picks up the AR(12) part of the process. The MA are exponentially decreasing modulo 12.

Indeed, the PACF and ACF behaviors for seasonal models are the same as classic ones, just everything is relative to the lags.

set.seed(666)
phi = c(rep(0,11),.9)
sAR = arima.sim(list(order=c(12,0,0), ar=phi), n=37)
sAR = ts(sAR, freq=12)
layout(matrix(c(1,1,2, 1,1,3), nc=2))

par(mar=c(3,3,2,1), mgp=c(1.6,.6,0))
plot(sAR, axes=FALSE, main='seasonal AR(1)', xlab="year", type='c')
Months = c("J","F","M","A","M","J","J","A","S","O","N","D")
points(sAR, pch=Months, cex=1.25, font=4, col=1:4) #cool way to plot it
axis(1, 1:4); abline(v=1:4, lty=2, col=gray(.7))
axis(2); box()
ACF = ARMAacf(ar=phi, ma=0, 100)
PACF = ARMAacf(ar=phi, ma=0, 100, pacf=TRUE)
plot(ACF,type="h", xlab="LAG", ylim=c(-.1,1)); abline(h=0)
plot(PACF, type="h", xlab="LAG", ylim=c(-.1,1)); abline(h=0)

Example 3.47 A Mixed Seasonal Model

An ARMA(0,1) \(\times (1,0)_{12}\) model \(x_t = \Phi x_{t-12} + w_t + \theta w_{t-1}\) Simulated below with \(\Phi = .8\) and \(\theta = -.5\) These type of correlation relationships are typically seen with seasonal data.

phi = c(rep(0,11),.8)
ACF = ARMAacf(ar=phi, ma=-.5, 50)[-1]
# [-1] removes 0 lag
PACF = ARMAacf(ar=phi, ma=-.5, 50, pacf=TRUE)
par(mfrow=c(1,2))
plot(ACF, type="h", xlab="LAG", ylim=c(-.4,.8)); abline(h=0)
plot(PACF, type="h", xlab="LAG", ylim=c(-.4,.8)); abline(h=0)

Example 3.49 Air Passengers

Taken from Box and Jenkins (1970), its monthly totals of international airline passengers, 1949-1960.

So, yeah, ddlx below looks stationary. (can be stationary but still seasonal). Note, that they did difference model on lx. Never did ddlx

x = AirPassengers
lx = log(x); dlx = diff(lx); ddlx = diff(dlx, 12)
plot.ts(cbind(x,lx,dlx,ddlx), main="")

# below of interest for showing seasonal RW (not shown here):
par(mfrow=c(2,1))
monthplot(dlx); monthplot(ddlx)

sarima(lx, 1,1,1, 0,1,1,12) # first try
## initial  value -3.085211 
## iter   2 value -3.225399
## iter   3 value -3.276697
## iter   4 value -3.276902
## iter   5 value -3.282134
## iter   6 value -3.282524
## iter   7 value -3.282990
## iter   8 value -3.286319
## iter   9 value -3.286413
## iter  10 value -3.288141
## iter  11 value -3.288262
## iter  12 value -3.288394
## iter  13 value -3.288768
## iter  14 value -3.288969
## iter  15 value -3.289089
## iter  16 value -3.289094
## iter  17 value -3.289100
## iter  17 value -3.289100
## iter  17 value -3.289100
## final  value -3.289100 
## converged
## initial  value -3.288388 
## iter   2 value -3.288459
## iter   3 value -3.288530
## iter   4 value -3.288649
## iter   5 value -3.288753
## iter   6 value -3.288781
## iter   7 value -3.288784
## iter   7 value -3.288784
## iter   7 value -3.288784
## final  value -3.288784 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), include.mean = !no.constant, transform.pars = trans, fixed = fixed, 
##     optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1      ma1     sma1
##       0.1960  -0.5784  -0.5643
## s.e.  0.2475   0.2132   0.0747
## 
## sigma^2 estimated as 0.001341:  log likelihood = 244.95,  aic = -481.9
## 
## $degrees_of_freedom
## [1] 128
## 
## $ttable
##      Estimate     SE t.value p.value
## ar1    0.1960 0.2475  0.7921  0.4298
## ma1   -0.5784 0.2132 -2.7127  0.0076
## sma1  -0.5643 0.0747 -7.5544  0.0000
## 
## $AIC
## [1] -3.393658
## 
## $AICc
## [1] -3.392434
## 
## $BIC
## [1] -3.312667
 #AR Parameter is not significant 
 # So try dropping it
sarima(lx, 0,1,1, 0,1,1,12) # second try i, drop AR 
## initial  value -3.086228 
## iter   2 value -3.267980
## iter   3 value -3.279950
## iter   4 value -3.285996
## iter   5 value -3.289332
## iter   6 value -3.289665
## iter   7 value -3.289672
## iter   8 value -3.289676
## iter   8 value -3.289676
## iter   8 value -3.289676
## final  value -3.289676 
## converged
## initial  value -3.286464 
## iter   2 value -3.286855
## iter   3 value -3.286872
## iter   4 value -3.286874
## iter   4 value -3.286874
## iter   4 value -3.286874
## final  value -3.286874 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), include.mean = !no.constant, transform.pars = trans, fixed = fixed, 
##     optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##           ma1     sma1
##       -0.4018  -0.5569
## s.e.   0.0896   0.0731
## 
## sigma^2 estimated as 0.001348:  log likelihood = 244.7,  aic = -483.4
## 
## $degrees_of_freedom
## [1] 129
## 
## $ttable
##      Estimate     SE t.value p.value
## ma1   -0.4018 0.0896 -4.4825       0
## sma1  -0.5569 0.0731 -7.6190       0
## 
## $AIC
## [1] -3.404219
## 
## $AICc
## [1] -3.403611
## 
## $BIC
## [1] -3.343475
sarima(lx, 1,1,0, 0,1,1,12) # another second ii, dropping the MA
## initial  value -3.085211 
## iter   2 value -3.259459
## iter   3 value -3.262637
## iter   4 value -3.275171
## iter   5 value -3.277007
## iter   6 value -3.277205
## iter   7 value -3.277208
## iter   8 value -3.277209
## iter   8 value -3.277209
## iter   8 value -3.277209
## final  value -3.277209 
## converged
## initial  value -3.279535 
## iter   2 value -3.279580
## iter   3 value -3.279586
## iter   3 value -3.279586
## iter   3 value -3.279586
## final  value -3.279586 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), include.mean = !no.constant, transform.pars = trans, fixed = fixed, 
##     optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## Coefficients:
##           ar1     sma1
##       -0.3395  -0.5619
## s.e.   0.0822   0.0748
## 
## sigma^2 estimated as 0.001367:  log likelihood = 243.74,  aic = -481.49
## 
## $degrees_of_freedom
## [1] 129
## 
## $ttable
##      Estimate     SE t.value p.value
## ar1   -0.3395 0.0822 -4.1295   1e-04
## sma1  -0.5619 0.0748 -7.5109   0e+00
## 
## $AIC
## [1] -3.390772
## 
## $AICc
## [1] -3.390164
## 
## $BIC
## [1] -3.330028
# The information criteria are more negative for version i. So kep that.

sarima.for(lx, 12, 0,1,1, 0,1,1,12) # sarima.for does a forecast. The 12 means for 12 months. Looks pretty good!
## $pred
##           Jan      Feb      Mar      Apr      May      Jun      Jul      Aug
## 1961 6.110186 6.053775 6.171715 6.199300 6.232556 6.368779 6.507294 6.502906
##           Sep      Oct      Nov      Dec
## 1961 6.324698 6.209008 6.063487 6.168025
## 
## $se
##             Jan        Feb        Mar        Apr        May        Jun
## 1961 0.03671562 0.04278291 0.04809072 0.05286830 0.05724856 0.06131670
##             Jul        Aug        Sep        Oct        Nov        Dec
## 1961 0.06513124 0.06873441 0.07215787 0.07542612 0.07855851 0.08157070

That’s the end of Chapter 3! Let’s take some SARIMA models to the data!

Chapter 4 Spectral Analysis and Filtering

folding frequency the highest frequency that can be seen in discrete sampling. Higher frequencies sampled this way will appear at lower frequencies called aliases.

4.1 Cyclical Behavior and Periodicity

Example 4.1 A Periodic Series

This is an example of a mixture of frequencies:

\[x_t = \sum_{k=1}^q \left [ U_{k1}\cos(2\pi \omega_k t) + U_{k2} \sin(2 \pi \omega_kt) \right ]\]

q = 3. \(\omega_1 = 6/100\), \(\omega_2 = 10/100\), \(\omega_3 = 40/100\). note that the individual contributions aren’t too obvious in the final variable x = x1 + x2 + x3.

x1 = 2*cos(2*pi*1:100*6/100) + 3*sin(2*pi*1:100*6/100)
x2 = 4*cos(2*pi*1:100*10/100) + 5*sin(2*pi*1:100*10/100)
x3 = 6*cos(2*pi*1:100*40/100) + 7*sin(2*pi*1:100*40/100)
x = x1 + x2 + x3
par(mfrow=c(2,2))
plot.ts(x1, ylim=c(-10,10), main=expression(omega==6/100~~~A^2==13))
plot.ts(x2, ylim=c(-10,10), main=expression(omega==10/100~~~A^2==41))
plot.ts(x3, ylim=c(-10,10), main=expression(omega==40/100~~~A^2==85))
plot.ts(x, ylim=c(-16,16), main="sum")

Example 4.2 Estimation and Periodogram

Oh wow. In this example, we take a fft and do identify the frequencies from Example 4.1, 6/100, 10/100 and 40/100. Note that the scaled periodogram function \(P(j/n)\) is such that \[P(j/n) = P(1 - j/n),\text{ } j = 0, 1, \dots, n-1\] So the frequencies are mirrored aroudn the “folding frequency” of 1/2. So, normally only plot the scaled periodogram function out to .5

Be careful in that different packages scale the FFT differently. Consult the package documentation.

The analogy between light and the periodogram as a prism decomposing waves into primary colors. Hence the term spectral analysis (like analyzing light waves.)

P = Mod(2*fft(x)/100)^2; Fr = 0:99/100
plot(Fr, P, type="o", xlab="frequency", ylab="scaled periodogram")

Example 4.3 Star Magnitude

600 consecutive dats of star (light) magnitude. Data taken from “The Calculus of Observations, a Treatise on Numerical Mathematics” by E.T. Whittaker and G Robinson 1923.

For the cycles, note that 29 days is about 1/.035 and a 24 day cycle is about 1/.041. They are the most prominent periodic components of the data.

Interpret the result as the observation of an amplitude modulated signal. For example, suppose we are observing signal-plus-noise \(x_t = s_t + v_t\). Here, \(s_t = \cos(2\pi \omega t) \cos(2 \pi \delta t)\) and \(\delta\) is very small. In this case the process will oscillate at frequency \(\omega\) but the amplitude will be modulated by \(\cos(2 \pi \delta t)\). Since \[2\cos(\alpha) \cos(\delta) = \cos(\alpha + \delta) + \cos(\alpha - \delta)\], the periodogram of data generated as \(x_t\) will have two peaks close to each other at \(\alpha \pm \delta\)

# testing the ideas above. See peaks at .2-.01 and .2+ .01. i.e. alpha = .2 and delta = .02
# since the fft is symmetric about .5, also see them around .8...
t = 1:200
plot.ts(x <- 2*cos(2*pi*.2*t)*cos(2*pi*.01*t)) # not shown
lines(cos(2*pi*.19*t)+cos(2*pi*.21*t), col=2) # the same

Px = Mod(fft(x))^2; plot(0:199/200, Px, type='o') # the periodogram

# reproducing with star data
n = length(star)
par(mfrow=c(2,1), mar=c(3,3,1,1), mgp=c(1.6,.6,0))
plot(star, ylab="star magnitude", xlab="day")
Per = Mod(fft(star-mean(star)))^2/n
Freq = (1:n -1)/n
plot(Freq[1:50], Per[1:50], type='h', lwd=3, ylab="Periodogram",
xlab="Frequency")
u = which.max(Per[1:50]) # 22 freq=21/600=.035 cycles/day
uu = which.max(Per[1:50][-u])# 25 freq=25/600=.041 cycles/day
1/Freq[22]; 1/Freq[26] # period = days/cycle
## [1] 28.57143
## [1] 24
text(.05, 7000, "24 day cycle"); text(.027, 9000, "29 day cycle") 

  ### another way to find the two peaks is to order on Per
y = cbind(1:50, Freq[1:50], Per[1:50]); y[order(y[,3]),]
##       [,1]        [,2]         [,3]
##  [1,]    1 0.000000000 9.443191e-29
##  [2,]    2 0.001666667 4.507982e-01
##  [3,]    3 0.003333333 6.383881e-01
##  [4,]    4 0.005000000 6.520257e-01
##  [5,]   42 0.068333333 8.665436e-01
##  [6,]    5 0.006666667 9.562050e-01
##  [7,]    6 0.008333333 1.102173e+00
##  [8,]    7 0.010000000 1.571938e+00
##  [9,]    8 0.011666667 1.919698e+00
## [10,]    9 0.013333333 2.660354e+00
## [11,]   50 0.081666667 2.716201e+00
## [12,]   49 0.080000000 2.950864e+00
## [13,]   48 0.078333333 3.131141e+00
## [14,]   10 0.015000000 3.360490e+00
## [15,]   41 0.066666667 3.434992e+00
## [16,]   47 0.076666667 3.436210e+00
## [17,]   46 0.075000000 3.727665e+00
## [18,]   45 0.073333333 4.217734e+00
## [19,]   40 0.065000000 4.333342e+00
## [20,]   11 0.016666667 4.602068e+00
## [21,]   44 0.071666667 4.961120e+00
## [22,]   39 0.063333333 5.104726e+00
## [23,]   38 0.061666667 5.787418e+00
## [24,]   12 0.018333333 6.000647e+00
## [25,]   37 0.060000000 6.609014e+00
## [26,]   36 0.058333333 7.479905e+00
## [27,]   43 0.070000000 7.759837e+00
## [28,]   13 0.020000000 8.299324e+00
## [29,]   35 0.056666667 8.579677e+00
## [30,]   34 0.055000000 9.855970e+00
## [31,]   14 0.021666667 1.130510e+01
## [32,]   33 0.053333333 1.149882e+01
## [33,]   32 0.051666667 1.354988e+01
## [34,]   15 0.023333333 1.626158e+01
## [35,]   31 0.050000000 1.627495e+01
## [36,]   30 0.048333333 1.994590e+01
## [37,]   16 0.025000000 2.384928e+01
## [38,]   29 0.046666667 2.512683e+01
## [39,]   28 0.045000000 3.282879e+01
## [40,]   17 0.026666667 3.760709e+01
## [41,]   27 0.043333333 4.499063e+01
## [42,]   18 0.028333333 6.410010e+01
## [43,]   25 0.040000000 1.085316e+02
## [44,]   19 0.030000000 1.276647e+02
## [45,]   24 0.038333333 2.152119e+02
## [46,]   20 0.031666667 3.395142e+02
## [47,]   23 0.036666667 6.436224e+02
## [48,]   21 0.033333333 2.136963e+03
## [49,]   26 0.041666667 9.011002e+03
## [50,]   22 0.035000000 1.102080e+04

4.2 The Spectral Density

The Spectral density is the fundamental frequency domain tool. It is covered in this chapter along with the spectral representations for stationary processes. Like the Wold decomposition justified the use of regression for analyzing time series, the spectral representation theorems supply the theoretical justifications for decomposing stationary time series into periodic components appearing in proportion to their underlying variances. See Appendix C for more.

4.3 Periodogram and Discrete Fourier Transform

Complex numbers in R. Showing how to calculate DFT (Discrete Fourier Transform) and its inverse (labeled idft in code below). Note the same operation does and then undoes them. i.e. fft(fft(x)) = x. Weird).

(dft = fft(1:4)/sqrt(4))
## [1]  5+0i -1+1i -1+0i -1-1i
#[1] 5+0i -1+1i -1+0i -1-1i
(idft = fft(dft, inverse=TRUE)/sqrt(4))
## [1] 1+0i 2+0i 3+0i 4+0i
#[1] 1+0i 2+0i 3+0i 4+0i
(Re(idft)) # keep it real
## [1] 1 2 3 4
#[1] 1 2 3 4

Example 4.10

x = c(1, 2, 3, 2, 1)
c1 = cos(2*pi*1:5*1/5);
s1 = sin(2*pi*1:5*1/5)
c2 = cos(2*pi*1:5*2/5);
s2 = sin(2*pi*1:5*2/5)
omega1 = cbind(c1, s1); omega2 = cbind(c2, s2)
anova(lm(x~omega1+omega2))
## Warning in anova.lm(lm(x ~ omega1 + omega2)): ANOVA F-tests on an essentially
## perfect fit are unreliable
## Analysis of Variance Table
## 
## Response: x
##           Df  Sum Sq Mean Sq F value Pr(>F)
## omega1     2 2.74164 1.37082               
## omega2     2 0.05836 0.02918               
## Residuals  0 0.00000
# ANOVA Table
Mod(fft(x))^2/5
## [1] 16.20000000  1.37082039  0.02917961  0.02917961  1.37082039
# the periodogram (as a check). Oh, raise it to the 2nd power then
# divide by 5 = n. right.
# the periodogram mod(fft(x))^2/5 seems to agree with the table presented in the book. In order they are.
# I(0) I(1/5) I(2/5)  I(3/5)  I(4/5)

Note, should remove trends before computing the periodogram. Trends introduce extremely low frequency components in the periodogram that tend to obscure the appearance at higher frequencies. So, either apply it to \(x_t - \bar{x}\) or \(x_t - \hat{\beta}_1 - \hat{\beta}_2 t\) (or higher order polynomial if nonlinearity in trend) to eliminate the terms that will be considered half cycles by the spectral analysis. (Oh sure, they will think it went up and is due to come down over the next n data observations.)

Note the FFT is easiest to calculate when \(n = 2^p\) for some p. (i.e. when n is a factor of 2). To accomodate this, if \(x_t^c\) is the detrended (i.e. centered) data, then just add zeros (e.g. \(x_{n+1}^c = x_{n+2}^c = \cdots = x_{n'}^c = 0\)) for \(n' = 2^p\). However, doing this will change the fundamental frequencies from \(j/n\) to \(j/n'\). So, need to bear this in mind. Just rescale them by \(n/n'\) when you find them. The command nextn can help with finding the most appropriate n. 

*Example 4.13 Periodogram of SOI and Recruitment Series

Note that the closer to the left the frequencies are, the longer the cycles they correspond to. So, the shortest frequency is \(\omega_j = 1/2\) and corresponds to data that cycles every two points. This would be the rightmost frequency in a standard periodogram (from 0 to 1/2 on the x-axis). That is *as we move from left to right in the periodogram, we are looking at indications for longer to shorter cycles.)

For the SOI, we see a strong spike at 1 (because increments are 1 step is \(w_j = 1/12\)). Very annoying labeling system. the 1/4 is actually 1/4$\(1/12 = 1/48 (corresponding to every 4 years). The periodogram goes to 6\)$1/12 = .5 as is standard. The little dancing around the \(1/4\) line is because there is some “unstable” cycle every 4 years or so. It looks like there may be some unstable cycles at the 2/12 (every 6 months) and 3/12 (every 4 months) frequencies, but less noticeable. The recruitment series (“rec”) shows the same underlying aptterns, but more dramatically in the case of the 4 year cycle.

Notice that the mvspec command is used in calculating and graphing the periodogram. (It’s great; the hardest part is understanding the math. R code is set up to generate all the analysis for you easily! Except for the confidence intervals. Its annoying those had to be calculated by hand.)

?nextn # to find the n that makes fft easiest to calculate.
# i believe the program does this automatically and then maybe
# recorrects it for you too?
nextn(453)
## [1] 480
nextn(950) #interesting
## [1] 960
par(mfrow=c(2,1))
soi.per = mvspec(soi, log="no")
abline(v=1/4, lty=2)
rec.per = mvspec(rec, log="no")
abline(v=1/4, lty=2)

# to calculate the confidnce intervals
# note that its 40/480. because 480 is the n that is used
# to make calculating easier! Even though the data had 453 originally
soi.per$spec[40] # 0.97223; soi pgram at freq 1/12 = 40/480
## [1] 0.9722312
soi.per$spec[10] # 0.05372; soi pgram at freq 1/48 = 10/480
## [1] 0.05372962
# conf intervals - returned value:
U = qchisq(.025,2) # 0.05063, upper bound weight
L = qchisq(.975,2) # 7.37775, lower bound weight
# recall its 2 * I(\omega_{j:n})/\chi_2^2(blah) where blah
# is \alpha/2 or 1 - \alpha/2
2*soi.per$spec[10]/L # 0.01456
## [1] 0.0145653
2*soi.per$spec[10]/U # 2.12220
## [1] 2.122207
2*soi.per$spec[40]/L # 0.26355
## [1] 0.2635573
2*soi.per$spec[40]/U # 38.40108
## [1] 38.40108

We see from here that the periodogram is a noisy estimator and we will need to find a way to reduce the variance to make it useful. This is actually obvious from the math: for any n, the periodogram is based on only two observations! (This is why 2 degrees of freedom.)

Moreover, \(I(\omega) \sim \frac{1}{2} f(\omega) \chi_2^2\) so \(E(I(\omega)) = f(\omega)\) and \(Var(I(\omega)) = f^2(\omega)\). Therefore the variance of \(I(\omega)\) is not shrinking in n. So, the periodogram is not a consistent (in the mean-squared sense) estimator of the spectral density. The solution to improving the estimate is using smoothing (nonparametric estimation).

4.4 Nonparametric Spectral Estimation

\[\bar{f}(\omega) = \frac{1}{L} \sum_{k=-m}^m I(\omega_j + k/n)\] over the band \(\mathcal{B} = \left \{ \omega^\star: \omega_j - m/n \le \omega^\star \le \omega_j + m/n \right \}\)

library(astsa)
arma.spec(ar=c(1,-.9), xlim=c(.15,.151), n.freq=100000)

Example 4.14 Averaged Periodogram for SOI and Recruitment

Should try a couple bandwidths at least. (i.e. try different values of L).

See an undesirable effect of averaging: the narrow band peaks that appeared in the periodograms in Figure 4.5 have been flatteened and spread out to nearby frequencies. Some Harmonics of the yearly cycle show up also (espeically in the soi plot); Harmonics typically occur when a periodic non-sinusoidal component is present.

library(pacman)
p_load(astsa)
soi.ave = mvspec(soi, kernel('daniell',4), log='no')
# note, when you specify the kernel, you give it the name (daniell)
# and m (here, m = 4.) Then L = 2m + 1 is the numerator of the bandwidth. So, you give it half the numerator of teh bandwidth, approximately. R notes call m the "kernel dimension". The displayed bandwidth is in terms of cycles per year rather than cycles per month. i.e. L/n = 9/480 for cycles per monoth, 12*L/n = .225 is cycles per year (How does R know its annual data? or is that the default in code)
abline(v=c(.25,1,2,3), lty=2)

soi.ave$bandwidth
## [1] 0.225
 # = 0.225
# Repeat above lines using rec in place of soi on line 3

rec.ave = mvspec(rec, kernel('daniell',4), log='no')
# note, when you specify the kernel, you give it the name (daniell)
# and m (here, m = 4.) Then L = 2m + 1 is the bandwidth. So, you 
# give it half the bandwidth approximately. 
abline(v=c(.25,1,2,3), lty=2)

rec.ave$bandwidth
## [1] 0.24
# Note, you don't have to choose the bandwidth
# R will compute one for you if you don't provide one!
# Probably better to start with theirs first. Its annoying that
# you provide m and it calculates a bandwidth in terms
# of L/n*12
rec.ave2 = mvspec(rec, kernel('daniell'), log='no')
abline(v=c(.25,1,2,3), lty=2)

rec.ave2$bandwidth
## [1] 0.1333333
# adjusted df = 2*L*n/n'
df = soi.ave$df
 # df = 16.9875 (returned values)
U = qchisq(.025, df)
 # U = 7.555916
L = qchisq(.975, df)
 # L = 30.17425
soi.ave$spec[10]
## [1] 0.04952026
 # 0.0495202
soi.ave$spec[40]
## [1] 0.11908
 # 0.1190800
# intervals
df*soi.ave$spec[10]/L
## [1] 0.02787891
 # 0.0278789
df*soi.ave$spec[10]/U
## [1] 0.1113333
 # 0.1113333
df*soi.ave$spec[40]/L
## [1] 0.06703963
 # 0.0670396
df*soi.ave$spec[40]/U
## [1] 0.2677201
 # 0.2677201

# note , log is not the default. have to add log='y' to it
# default is log='n' now
soi.avelog = mvspec(soi, kernel('daniell',4), log='y')
abline(v=c(.25,1,2,3), lty=2)

soi.avelog$bandwidth #same just y axis is log transformed
## [1] 0.225
rec.avelog = mvspec(rec, kernel('daniell',4), log='y')
abline(v=c(.25,1,2,3), lty=2)

rec.avelog$bandwidth #same, just y axis is log transformed
## [1] 0.24
# log transformed is totally different looking and I think misleading even?

Example 4.15 Harmonics

Minor peaks at the annual harmonics displayed in previous example. That is, signal psectra had peak at \(\omega=1\Delta = 1/12\) and minor peaks at \(\omega = k \Delta\) for \(k = 2,3,\dots\). The harmonics are needed to capture the non-sinusoidal behavior of the signal.

Generate a signal \(x_t\) as follows: \[x_t = \sin(2\pi2t) + .5 \sin(2 \pi 4t) + .4 sin(2\pi 6t) + .3 \sin(2 \pi 8 t) + .2 \sin (2 \pi 10 t) + .1 \sin (2 \pi 12 t)\] You can see its got frequencies from 2 to 12 and the amplitude keeps shrinking as the frequencies frow (periods shrink.) The fundamental frequency is the shortest frequency (2) or longest period/wavelength (1/2). The higher harmonics have shorter wavelength (longer frequency).

t = seq(0, 1, by=1/200)
amps = c(1, .5, .4, .3, .2, .1)
x = matrix(0, 201, 6)
for (j in 1:6){ x[,j] = amps[j]*sin(2*pi*t*2*j) }
x = ts(cbind(x, rowSums(x)), start=0, deltat=1/200)
ts.plot(x, lty=c(1:6, 1), lwd=c(rep(1,6), 2), ylab="Sinusoids")
names = c("Fundamental","2nd Harmonic","3rd Harmonic","4th Harmonic", 
   "5th Harmonic", "6th Harmonic", "Formed Signal")
legend("topright", names, lty=c(1:6, 1), lwd=c(rep(1,6), 2))

kernel("modified.daniell", c(1,1))
## mDaniell(1,1) 
## coef[-2] = 0.0625
## coef[-1] = 0.2500
## coef[ 0] = 0.3750
## coef[ 1] = 0.2500
## coef[ 2] = 0.0625

What we learn is that we need systematic procedures for deciding whether peaks are significant.

Example 4.16 Smoothed Periodogram for SOI and Recruitment

A key difference we see between nonparametrics on the periodogram and nonparametrics in continuous regression is that the weights and points to be incorporated are distributed over discrete points rather than continuous points. This means the distribution of weights will be discrete distribution and can be described fairly simply. Also, which points to incorporate will be too. But, we will see more jumps in our choice of bandwidth for discrete distributions, probably. So, be sure to play around with it for discrete.

The claim is that for this is the modified daniell kernel did a better job than the previous daniell kernel. Note also that there was a taper added to this picture.

kernel("modified.daniell", c(3,3))
## mDaniell(3,3) 
## coef[-6] = 0.006944
## coef[-5] = 0.027778
## coef[-4] = 0.055556
## coef[-3] = 0.083333
## coef[-2] = 0.111111
## coef[-1] = 0.138889
## coef[ 0] = 0.152778
## coef[ 1] = 0.138889
## coef[ 2] = 0.111111
## coef[ 3] = 0.083333
## coef[ 4] = 0.055556
## coef[ 5] = 0.027778
## coef[ 6] = 0.006944
#coef[-6] = 0.006944 = coef[ 6]
#coef[-5] = 0.027778 = coef[ 5]
#coef[-4] = 0.055556 = coef[ 4]
#coef[-3] = 0.083333 = coef[ 3]
#coef[-2] = 0.111111 = coef[ 2]
#coef[-1] = 0.138889 = coef[ 1]
#coef[ 0] = 0.152778
plot(kernel("modified.daniell", c(3,3)))

 # not shown


k = kernel("modified.daniell", c(3,3))
soi.smo = mvspec(soi, kernel=k, taper=.1, log="no")
abline(v=c(.25,1), lty=2)

## Repeat above lines with rec replacing soi in line 3
df = soi.smo$df
 # df = 17.42618
soi.smo$bandwidth
## [1] 0.2308103
 # B = 0.2308103
soi.smo = mvspec(soi, taper=.1, spans=c(7,7))

# spans is a vector of odd integers given in terms of L = 2m+ 1

soi.smo = mvspec(soi, kernel=k, taper=.1, log="yes")

  # the log one is hard to interpret. seems like a bad idea in general.

Note, that it may be appropriate to allow the bandwidth to vary across the estimating spectrum. This is seen here in that the the smoothing bandwidth for the broadband El Nino behavior near the 4 year cycle should be much larger than the bandwidth for the annual cycle (which is frather to the write on the periodogram). See Fan and Kreutzberger (1998) for more on what is called “automatic adaptive smoothing for estimating the spectrum.”

Example 4.17 The Effect of Tapering the SOI Series

The tapered example does a better job in separating the yearly cycle and the El Nino cycle. The lack of a dip between the dips between the yearly and El Nino cycle in the untapered example is called “leakage”. Essentially, one cycle’s estimated frequency is “leaking” into the other cycle’s estimated frequency in the case without tapering. See it between 0 and 1 on the plot below with dashed line above solid line. (It seems to me that the leakage isn’t that bad and you can still distinguish the two peaks, though.)

s0 = mvspec(soi, spans=c(7,7), plot=FALSE)
 # no taper
s50 = mvspec(soi, spans=c(7,7), taper=.5, plot=FALSE)
 # full taper
plot(s50$freq, s50$spec, log="y", type="l", ylab="spectrum",
xlab="frequency")
 # solid line
lines(s0$freq, s0$spec, lty=2)

 # dashed line

4.5 Parametric Spectral Estimation

So, it turns out any stationary process can be approximated arbitrarily well by a (perhaps very high order) AR(p) process. The asymptotic distribution of the AR(p) estimate is sketchy; the authors encourage us to use the bootstrap for CI instead.

So, rather than use mvspec for nonparametric kernel estimates, can use spec.ar.

Example 4.18 Autoregressive Spectral Estimator for SOI

spaic = spec.ar(soi, log="no") #to generate ar spectral estimate
 # min AIC spec
abline(v=frequency(soi)*1/52, lty=3)

 # El Nino peak
# These are showing AIC for different order length fits
# No likelihood is calculated here os the use of the term AIC is "loose."
(soi.ar = ar(soi, order.max=30))
## 
## Call:
## ar(x = soi, order.max = 30)
## 
## Coefficients:
##       1        2        3        4        5        6        7        8  
##  0.4237   0.0803   0.1411   0.0750  -0.0446  -0.0816  -0.0686  -0.0640  
##       9       10       11       12       13       14       15  
##  0.0159   0.1099   0.1656   0.1482   0.0231  -0.1814  -0.1406  
## 
## Order selected 15  sigma^2 estimated as  0.07575
 # estimates and AICs
dev.new()
plot(1:30, soi.ar$aic[-1], type="o")
 # plot AICs; looks like 15 is right number of lag terms from AIC perspective.
# AIC and AICc are nearly identical so just graphed AIC and BIC+1
n = length(soi)
AIC = rep(0, 30) -> AICc -> BIC
for (k in 1:30){
sigma2 = ar(soi, order=k, aic=FALSE)$var.pred
BIC[k] = log(sigma2) + (k*log(n)/n)
AICc[k] = log(sigma2) + ((n+k)/(n-k-2))
AIC[k] = log(sigma2) + ((n+2*k)/n)
 }
IC = cbind(AIC, BIC+1)
ts.plot(IC, type="o", xlab="p", ylab="AIC / BIC") #15 for BIC too

4.6 Multiple Series and Cross-Spectra

Example 4.21 Coherence Between SOI and Recruitment

In this picture, the blue lines are confidence bands and the black line is alpha = .001 significance level. Bear in mind that the Bonferroni inequality means we have to have some caution in interpreting all the points above this line as significant.

It looks like, from the picture, that the two series are “coherent” during the 1 year frequency. They also look strongly coherent at lower frequencies, which may be El Nino which have a 3-7 year period. The peak in coherency occurs at the 9 year cycle. As you go farther to the right along the plot, the underlying power spectrum is small and therefore we should be more skeptical of these close to the end. Finally, note that the coherence is persistent at the seasonal harmonic frequencies.

sr = mvspec(cbind(soi,rec),
 kernel("daniell",9), plot=FALSE)
sr$df # df = 35.8625
f = qf(.999, 2, sr$df-2) # = 8.529792
C = f/(18+f) # = 0.321517
plot(sr, plot.type = "coh", ci.lty = 2)
abline(h = C)

4.7 Linear Filters

Example 4.22 First Difference and Moving Average Filters

Looking at two filters. 1) is a first difference filter and (2) is an annual symmetric MA filter (which is essentially the modified daniell kernel with m = 6 if monthly data.)

  1. \(y_t = \nabla x_t\)
  2. \(y_t = (x_{t-6} + x_{t+6})/24 + \sum_{r=-5}^5 x_{t-r}/12\)

The first one is called a high-pass filter, since it keeps the higher frequency patterns. The second is called a low-pass filter since it keeps the lower frequencies. (I don’t know, how do you know you’re not creating new frequency patterns when you use these filters? especailly the 2nd one?) The claim is that the

par(mfrow=c(3,1), mar=c(3,3,1,1), mgp=c(1.6,.6,0))
plot(soi)
 # plot data
plot(diff(soi))
 # plot first difference
k = kernel("modified.daniell", 6) # filter weights
plot(soif <- kernapply(soi, k))

 # plot 12 month filter
dev.new()
spectrum(soif, spans=9, log="no") # spectral analysis (not shown)
abline(v=12/52, lty="dashed")
dev.new()
##-- frequency responses --##
par(mfrow=c(2,1), mar=c(3,3,1,1), mgp=c(1.6,.6,0))
w = seq(0, .5, by=.01)
FRdiff = abs(1-exp(2i*pi*w))^2
plot(w, FRdiff, type="l", xlab='frequency')
u = cos(2*pi*w)+cos(4*pi*w)+cos(6*pi*w)+cos(8*pi*w)+cos(10*pi*w)
FRma = ((1 + cos(12*pi*w) + 2*u)/12)^2
plot(w, FRma, type='l', xlab='frequency')

4.8 Lagged Regression Models

Example 4.24 Lagged Regression for SOI and Recruitment

Let \(x_t\) denote the SOI series and \(y_t\) denote the Recruitment series. We will write the SOI as the input with the following model:

\[y_t = \sum_{r=-\infty}^\infty a_r x_{t-r} + w_t\]

A model that reverses the two roles will be denoted as \[x_t = \sum_{r=-\infty}^\infty b_r y_{t-r} + \nu_t\]

Here, \(w_t\) and \(\nu_t\) are white noise processes. Use the R script LagReg from astsa. Use M=32 and L=15 (based on ???).

# Forward REgression
LagReg(soi, rec, L=15, M=32, threshold=6)

Note that the one line of code does a lot!

The regression output suggests a possible model \[y_t = 66 - 18.5x_{t-5} - 12.3x_{t-6} - 8.5 x_{t-7} - 7 x_{t-8} + w_t\] Of course, this model ignores some coefficients that are not that small

# Reverse Regression
LagReg(rec, soi, L=15, M=32, inverse=TRUE, threshold=.01)

Note that this regression actually produces a much easier-to-interpret model! Or more parsimonious. Just two obviously significant lag terms. So we can write \[x_t = .41 + .016 y_{t+5} - .02y_{t+5} + v_t\]. We can now solve this equation for \(y_t\) Namely, multiplying each side by \(50B^5\) gets us \[(1 - .8B)y_t = 20.5 - 50B^5 x_t + \epsilon_t\]**So a good strategy can be to try both regressions and invert the simpler one!

Finally, do some checks to verify the final \(\epsilon_t\) noise is white. We will rerun the regression with autocorrelated errors and reestimate the coefficients. This is referred to as an ARMAX model (the X stands for exogenous; see Section 5.6 and Section 6.6.1):

fish = ts.intersect(R=rec, RL1=lag(rec,-1), SL5=lag(soi,-5))
(u = lm(fish[,1]~fish[,2:3], na.action=NULL))
## 
## Call:
## lm(formula = fish[, 1] ~ fish[, 2:3], na.action = NULL)
## 
## Coefficients:
##    (Intercept)  fish[, 2:3]RL1  fish[, 2:3]SL5  
##        11.3188          0.8432        -20.3226
acf2(resid(u)) # suggests ar1

##      [,1]  [,2]  [,3]  [,4]  [,5] [,6]  [,7] [,8]  [,9] [,10] [,11] [,12] [,13]
## ACF   0.4  0.10 -0.04 -0.15 -0.03 0.06 -0.02 0.00 -0.07 -0.11 -0.10 -0.10 -0.10
## PACF  0.4 -0.08 -0.06 -0.13  0.11 0.05 -0.10 0.03 -0.07 -0.05 -0.06 -0.04 -0.07
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.07 -0.08 -0.08  0.01  0.01 -0.02 -0.02  0.02  0.03  0.05  0.03  0.00
## PACF -0.04 -0.06 -0.05  0.05 -0.03 -0.04 -0.03  0.05 -0.01 -0.02 -0.01 -0.02
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.03  0.08  0.07  0.08  0.05  0.00 -0.12 -0.13 -0.03  0.06  0.10  0.07
## PACF  0.03  0.06  0.00  0.04  0.01 -0.01 -0.14 -0.02  0.06  0.05  0.03  0.03
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF  -0.07 -0.13 -0.03  0.05  0.08  0.04 -0.01 -0.08 -0.08 -0.04  0.01
## PACF -0.09 -0.04  0.09  0.06  0.00 -0.04  0.00 -0.08 -0.02  0.01  0.00
sarima(fish[,1], 1, 0, 0, xreg=fish[,2:3])
## initial  value 2.048660 
## iter   2 value 1.959354
## iter   3 value 1.957852
## iter   4 value 1.952830
## iter   5 value 1.952604
## iter   6 value 1.952323
## iter   7 value 1.952158
## iter   8 value 1.952133
## iter   9 value 1.952131
## iter  10 value 1.952131
## iter  10 value 1.952131
## final  value 1.952131 
## converged
## initial  value 1.951958 
## iter   2 value 1.951957
## iter   3 value 1.951954
## iter   4 value 1.951953
## iter   5 value 1.951953
## iter   6 value 1.951953
## iter   7 value 1.951953
## iter   7 value 1.951953
## iter   7 value 1.951953
## final  value 1.951953 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1  intercept     RL1       SL5
##       0.4507    14.6998  0.7895  -21.0481
## s.e.  0.0497     1.5644  0.0230    1.0823
## 
## sigma^2 estimated as 49.57:  log likelihood = -1503.42,  aic = 3016.83
## 
## $degrees_of_freedom
## [1] 442
## 
## $ttable
##           Estimate     SE  t.value p.value
## ar1         0.4507 0.0497   9.0713       0
## intercept  14.6998 1.5644   9.3966       0
## RL1         0.7895 0.0230  34.2583       0
## SL5       -21.0481 1.0823 -19.4474       0
## 
## $AIC
## [1] 6.764204
## 
## $AICc
## [1] 6.764407
## 
## $BIC
## [1] 6.810171
 # armax model; the x stands for exogenous

Our final parsimonious fitted model is

\[y_t = 12 + .8y_{t-1} - 21 x_{t-5} + \epsilon_t\] where \(\epsilon_t = .45 \epsilon_{t-1} + w_t\)

Note that the authors keep referring to the \(\beta_r\) as relating the \(x_t\) to the \(y_t\) series (or vice versa) as the “transfer functions”. That is, the transfer functions translate changes in one series to another series. This is why macroeconomists call functions like this transfer functions. This is not to be confused with transport functions.

4.9 Signal Extraction and Optimum Filtering

Wait, if we are looking in the frequency space, does that mean we are assuming that there is a pattern to the signal? As in, it comes in and goes away regularly. Rather than just these weird events or random phenomenon? For my problem, I don’t want to extract a steady hidden pulse, but rather times of persistently uncharacteristic behavior. What I really want is GARCH then.

Alternatively, I think I could imagine it as a signal extraction process if I want to isolate the annual cycle. Then, the remainder as the “noise”, see when it peaks. So, I guess there are kind of two ways you can think about the problem, depending what you think is “noise” and what you think is informational in your process.

At the end of the day, all the solution techniques are about sorting your data into explainable and unexplainable parts. Its just, what part of the explainable parts are you interested in? Low-frequency, high-frequency? etc…

Example 4.25 Estimating the El Nino Signal via Optimal Filters

Assume the simple signal plus noise model:

\(y_t = x_t + \nu_t\) so that there is no convolving function \(\beta_t\). We notice the El Nino frequency of about .02 cycles per month ( the four-year cycle) and a yearly frequency of about .08 cycles per month (the annual cycle). We assume that we wish to preserve the lower frequency as signal and to eliminate the higher order frequencies. So, the signal-to-noise ratio is assumed to be high from 0 to about .06 cycles per month and zero thereafter.So, choose one that’s 1 from 0 to .05 and then decays linearly to zero in several steps.

In the pictures below, they would like that box-like filter. But, they have to taper it to avoid the ripples, so get the bump-filter.

# graphics.off()
SigExtract(soi, L=9, M=64, max.freq=.05)
## The filter coefficients are 
##         s          a(s)
##  [1,]   0  9.375000e-02
##  [2,]  -1  9.142572e-02
##  [3,]  -2  8.465653e-02
##  [4,]  -3  7.403075e-02
##  [5,]  -4  6.045654e-02
##  [6,]  -5  4.506290e-02
##  [7,]  -6  2.907894e-02
##  [8,]  -7  1.370627e-02
##  [9,]  -8  4.571434e-18
## [10,]  -9 -1.122791e-02
## [11,] -10 -1.947220e-02
## [12,] -11 -2.455895e-02
## [13,] -12 -2.663061e-02
## [14,] -13 -2.609582e-02
## [15,] -14 -2.355291e-02
## [16,] -15 -1.969867e-02
## [17,] -16 -1.523546e-02
## [18,] -17 -1.078860e-02
## [19,] -18 -6.844241e-03
## [20,] -19 -3.713650e-03
## [21,] -20 -1.526152e-03
## [22,] -21 -2.482988e-04
## [23,] -22  2.766258e-04
## [24,] -23  2.771938e-04
## [25,] -24  1.598625e-19
## [26,] -25 -3.376583e-04
## [27,] -26 -5.815546e-04
## [28,] -27 -6.566509e-04
## [29,] -28 -5.648692e-04
## [30,] -29 -3.671415e-04
## [31,] -30 -1.550378e-04
## [32,] -31 -1.886644e-05
## for s >=0; and a(-s) = a(s).

Does any of this have anything to do with wavelets?

4.10 Spectral Analysis of Multidimensional Series

Example 4.26 Soil Surface Temperatures

This gets into some pretty interesting stuff, actually. This is looking a lot like the heat equation. Multidimensional waves running across a surface. Look for the set of \((\omega_j, \omega_k)\) that correspond to the wave frequency in both dimensions. It is weird to think about a wave that has different y-dimension frequency than x-dimension. Any purely one dimensional waves would be on the x- or y-axis I guess of two-dimensional periodogram.

In this example, all the strong frequencies have column frequency zero. So, all the patterns are aross rows.

per = Mod(fft(soiltemp-mean(soiltemp))/sqrt(64*36))^2
per2 = cbind(per[1:32,18:2], per[1:32,1:18])
per3 = rbind(per2[32:2,],per2)
par(mar=c(1,2.5,0,0)+.1)
persp(-31:31/64, -17:17/36, per3, phi=30, theta=30, expand=.6,
      ticktype="detailed", xlab="cycles/row", ylab="cycles/column",
      zlab = "Periodogram Ordinate")

Chapter 5 Additional Time Domain Topics

This chapter covers topics that are special or advanced in the time domain. The next chapter, Chapter 6, is devoted to one of the most useful and interesting time domain topics: state-space models. Therefore, they do not cover state space models in chapter 5. Most of the sections in this chapter can be read in any order.

5.1 Long Memory ARMA and Fractional Differencing

Long memory aka persistent time series.

Often call ARMA(p,q) process as short-memory process because the coefficients are dominated by exponential decay. Before, the advice was that if the ACF of a time series decays slowly, difference the series until it seems stationary.

Sometimes, however, using the differenced model may be too severe a modification, in that it may be an overdifferencing of the original process. Apparently this goes back to Granger and Joyeux (1980). Basic idea, “partly difference it. i.e. for \(d\in (0, .5)\),put \((1 - B)^dx_t = w_t\) Estimate \(d\) along with \(\sigma_w^2\). Call the factionally differenced series”fractional noise".

(What does that mean even if d = .5? Estimate something a half time-step between and remove it? What it actually means is to use the Gamma function to generate the coefficients. ie. for \(( d > -1 )\) we can write \[w_t = (1 - B)^dx_t = \sum_{j=0}^\infty \pi_j B^jw_t = \sum_{j=0}^\infty \pi_j w_{t-j}\] where \(\pi_j = \frac{\Gamma(j - d)}{\Gamma(j + 1)\Gamma(-d)}\) and for \(d < 1\), we can invert that formula to get \[x_t = (1 - B)^{-d}_t = \sum_{j=0}^\infty \psi_j B^jw_t = \sum_{j=0}^\infty \psi_j w_{t-j} \] where \(\psi_j = \frac{\Gamma(j + d)}{\Gamma(j+1)\Gamma(d)}\) Brockwell and Davis explain it more carefully.

In the case of fractional differencing, just require \(\sum \pi_j^2<\infty\) rather than \(\sum |\pi_j|^2 < \infty\) (but since their squared, as long as the coefficients are real, isn’t this equivalent?)

Can show for \(0<d<1\) \[\rho(h) = \frac{\Gamma(h + d)\Gamma(1-d)}{\Gamma(h - d + 1)\Gamma(d)} \sim h^{2d-1}\] for large h. Therefore, for \(0<d<1/2\) \(\sum_{h=-\infty}^\infty |\rho(h)| = \infty\) and hence “long memory”

“ARFIMA = Fractionally Integrated ARMA”

# Sample ACF of the log-transformed varce series
# It exhibits classic long memory behavior
acf(log(varve), 100)

acf(cumsum(rnorm(1000)), 100)

 # compare to ACF of random walk (not shown)

Example 5.1 Long Memory Fitting of the Glacial Varve Series

In example 3.41 analyzed this as a ARIMA(1,1,1) process. Now, fit the fractionally differenced model \((1-B)^dx_t = w_t\) to the mean-adjusted series \(x_t - \bar{x}\). Start with a guess of \(d=.1\), omit the first 30 points from the computation leads to a final value of \(d = .384\). This tells us the entire coefficient chain \(\pi_j(.384)\) for each \(j\)! (So, it looks like a model with many terms, but all you are fitting is \(d\), no other coefficients. So it really only has 1 degree of freedom. I find it hard to believe this is a good strategy in general!)

# Need the fracdiff package
library(pacman)
p_load(fracdiff)
lvarve = log(varve)-mean(log(varve))
varve.fd = fracdiff(lvarve, nar=0, nma=0, M=30)
varve.fd$d
## [1] 0.3841688
 # = 0.3841688
varve.fd$stderror.dpq
## [1] 4.589514e-06
 # = 4.589514e-06 (questionable result!!)
p = rep(1,31)
for (k in 1:30){ p[k+1] = (k-varve.fd$d)*p[k]/(k+1) }
plot(1:30, p[-1], ylab=expression(pi(d)), xlab="Index", type="h")

res.fd = diffseries(log(varve), varve.fd$d)
 # frac diff resids
res.arima = resid(arima(log(varve), order=c(1,1,1))) # arima resids
par(mfrow=c(2,1))
acf(res.arima, 100, xlim=c(4,97), ylim=c(-.2,.2), main="")
acf(res.fd, 100, xlim=c(4,97), ylim=c(-.2,.2), main="")

Example 5.2 Long Memory Spectra for the Varve Series

series = log(varve)
 # specify series to be analyzed
d0 = .1
 # initial value of d
n.per = nextn(length(series))
m = (n.per)/2 - 1
per = Mod(fft(series-mean(series))[-1])^2 # remove 0 freq and
per = per/n.per
 # scale the peridogram
g = 4*(sin(pi*((1:m)/n.per))^2)
# Function to calculate -log.likelihood
whit.like = function(d){
g.d=g^d
sig2 = (sum(g.d*per[1:m])/m)
log.like = m*log(sig2) - d*sum(log(g)) + m
return(log.like)
 }
# Estimation (output not shown)
(est = optim(d0, whit.like, gr=NULL, method="L-BFGS-B", hessian=TRUE,
lower=-.5, upper=.5, control=list(trace=1,REPORT=1)))
## iter    1 value -145.635158
## iter    2 value -150.428661
## iter    3 value -152.601414
## iter    4 value -152.942481
## iter    5 value -152.952753
## iter    6 value -152.952788
## iter    7 value -152.952788
## final  value -152.952788 
## converged
## $par
## [1] 0.3802707
## 
## $value
## [1] -152.9528
## 
## $counts
## function gradient 
##        8        8 
## 
## $convergence
## [1] 0
## 
## $message
## [1] "CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH"
## 
## $hessian
##          [,1]
## [1,] 1232.464
##-- Results: d.hat = .380, se(dhat) = .028, and sig2hat = .229 --##
cat("d.hat =", est$par, "se(dhat) = ",1/sqrt(est$hessian),"\n")
## d.hat = 0.3802707 se(dhat) =  0.02848478
g.dhat = g^est$par; sig2 = sum(g.dhat*per[1:m])/m
cat("sig2hat =",sig2,"\n")
## sig2hat = 0.2293286
u = spec.ar(log(varve), plot=FALSE) # produces AR(8)
g = 4*(sin(pi*((1:500)/2000))^2)
fhat = sig2*g^{-est$par} # long memory spectral estimate
plot(1:500/2000, log(fhat), type="l", ylab="log(spectrum)", xlab="frequency")
lines(u$freq[1:250], log(u$spec[1:250]), lty="dashed")
ar.mle(log(varve)) # to get AR(8) estimates


library(fracdiff)
fdGPH(log(varve), bandw=.9) # m = n^bandw
dhat = 0.383
se(dhat) = 0.041

5.2 Unit Root Testing

library(tseries)
## Registered S3 method overwritten by 'quantmod':
##   method            from
##   as.zoo.data.frame zoo
adf.test(log(varve), k=0)
## Warning in adf.test(log(varve), k = 0): p-value smaller than printed p-value
## 
##  Augmented Dickey-Fuller Test
## 
## data:  log(varve)
## Dickey-Fuller = -12.857, Lag order = 0, p-value = 0.01
## alternative hypothesis: stationary
 # DF test
#Dickey-Fuller = -12.8572, Lag order = 0, p-value < 0.01
#alternative hypothesis: stationary
adf.test(log(varve))
## 
##  Augmented Dickey-Fuller Test
## 
## data:  log(varve)
## Dickey-Fuller = -3.5166, Lag order = 8, p-value = 0.04071
## alternative hypothesis: stationary
 # ADF test
#Dickey-Fuller = -3.5166, Lag order = 8, p-value = 0.04071
#alternative hypothesis: stationary
pp.test(log(varve))
## Warning in pp.test(log(varve)): p-value smaller than printed p-value
## 
##  Phillips-Perron Unit Root Test
## 
## data:  log(varve)
## Dickey-Fuller Z(alpha) = -304.54, Truncation lag parameter = 6, p-value
## = 0.01
## alternative hypothesis: stationary
 # PP test
#Dickey-Fuller Z(alpha) = -304.5376,
#Truncation lag parameter = 6, p-value < 0.01
#alternative hypothesis: stationary

5.3 GARCH Models

The study of the volatility (or variability around trend) of a time series. For situations where the assumption of a constant conditional mean is violated.

  • ARCH = Autoregressive Conditionally Heteroscedastic
    • Extended to generalized ARCH = GARCH
  • concerned with modeling the return or growth rate of a series.

\[r_t = (x_t - x_{t-1})/x_{t-1} \Rightarrow x_t = (1+r_t)x_{t-1}\] If the return \(r_t\) represents a small (in magnitude) percentage change then \[\nabla \log(x_t) \approx r_t\]

Call either one the “return.”

Example 5.4 Analysis of US GNP

u = sarima(diff(log(gnp)), 1, 0, 0)
## initial  value -4.589567 
## iter   2 value -4.654150
## iter   3 value -4.654150
## iter   4 value -4.654151
## iter   4 value -4.654151
## iter   4 value -4.654151
## final  value -4.654151 
## converged
## initial  value -4.655919 
## iter   2 value -4.655921
## iter   3 value -4.655922
## iter   4 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## final  value -4.655922 
## converged

acf2(resid(u$fit)^2, 20)

##      [,1] [,2] [,3] [,4]  [,5] [,6]  [,7] [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.12 0.13 0.03 0.13  0.01 0.05 -0.03 0.06 0.08 -0.08  0.09  0.10  0.01
## PACF 0.12 0.12 0.00 0.12 -0.02 0.02 -0.04 0.05 0.08 -0.12  0.11  0.09 -0.05
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20]
## ACF   0.04  0.15 -0.02  0.04 -0.05  0.01  0.05
## PACF  0.05  0.13 -0.09  0.01 -0.05  0.00  0.04
library(fGarch)
## Loading required package: timeDate
## Loading required package: timeSeries
## 
## Attaching package: 'timeSeries'
## The following object is masked from 'package:zoo':
## 
##     time<-
## Loading required package: fBasics
## 
## Attaching package: 'fBasics'
## The following object is masked from 'package:astsa':
## 
##     nyse
summary(garchFit(~arma(1,0)+garch(1,0), diff(log(gnp))))
## 
## Series Initialization:
##  ARMA Model:                arma
##  Formula Mean:              ~ arma(1, 0)
##  GARCH Model:               garch
##  Formula Variance:          ~ garch(1, 0)
##  ARMA Order:                1 0
##  Max ARMA Order:            1
##  GARCH Order:               1 0
##  Max GARCH Order:           1
##  Maximum Order:             1
##  Conditional Dist:          norm
##  h.start:                   2
##  llh.start:                 1
##  Length of Series:          222
##  Recursion Init:            mci
##  Series Scale:              0.01015924
## 
## Parameter Initialization:
##  Initial Parameters:          $params
##  Limits of Transformations:   $U, $V
##  Which Parameters are Fixed?  $includes
##  Parameter Matrix:
##                      U          V    params includes
##     mu     -8.20681904   8.206819 0.8205354     TRUE
##     ar1    -0.99999999   1.000000 0.3466459     TRUE
##     omega   0.00000100 100.000000 0.1000000     TRUE
##     alpha1  0.00000001   1.000000 0.1000000     TRUE
##     gamma1 -0.99999999   1.000000 0.1000000    FALSE
##     delta   0.00000000   2.000000 2.0000000    FALSE
##     skew    0.10000000  10.000000 1.0000000    FALSE
##     shape   1.00000000  10.000000 4.0000000    FALSE
##  Index List of Parameters to be Optimized:
##     mu    ar1  omega alpha1 
##      1      2      3      4 
##  Persistence:                  0.1 
## 
## 
## --- START OF TRACE ---
## Selected Algorithm: nlminb 
## 
## R coded nlminb Solver: 
## 
##   0:     682.89527: 0.820535 0.346646 0.100000 0.100000
##   1:     308.43148: 0.763492 0.258112  1.06104 0.352453
##   2:     306.07332: 0.681276 0.195897  1.04763 0.304072
##   3:     301.00807: 0.561958 0.448458 0.825277 0.0402737
##   4:     298.88361: 0.383716 0.465477 0.632947 0.385969
##   5:     296.74288: 0.504144 0.389445 0.683634 0.247795
##   6:     296.67703: 0.497724 0.366843 0.688130 0.229496
##   7:     296.60039: 0.500011 0.385702 0.703145 0.211105
##   8:     296.59692: 0.515645 0.374174 0.690079 0.194961
##   9:     296.56381: 0.513570 0.367018 0.702272 0.200013
##  10:     296.55723: 0.523440 0.363125 0.708406 0.194152
##  11:     296.55632: 0.522578 0.364912 0.710103 0.194839
##  12:     296.55598: 0.520871 0.364956 0.710924 0.193212
##  13:     296.55568: 0.519486 0.366572 0.710213 0.194509
##  14:     296.55568: 0.519508 0.366596 0.710266 0.194513
##  15:     296.55568: 0.519511 0.366586 0.710289 0.194454
##  16:     296.55568: 0.519505 0.366563 0.710298 0.194465
##  17:     296.55568: 0.519526 0.366560 0.710295 0.194472
##  18:     296.55568: 0.519522 0.366563 0.710295 0.194471
## 
## Final Estimate of the Negative LLH:
##  LLH:  -722.2849    norm LLH:  -3.253536 
##           mu          ar1        omega       alpha1 
## 0.0052779473 0.3665625267 0.0000733096 0.1944713494 
## 
## R-optimhess Difference Approximated Hessian Matrix:
##                  mu           ar1         omega        alpha1
## mu     -2749495.312 -24170.124266  4.546826e+06 -1.586691e+03
## ar1      -24170.124   -390.266806  1.253875e+04 -6.733799e+00
## omega   4546825.892  12538.746433 -1.590043e+10 -7.069340e+05
## alpha1    -1586.691     -6.733799 -7.069340e+05 -1.425395e+02
## attr(,"time")
## Time difference of 0.004904747 secs
## 
## --- END OF TRACE ---
## 
## 
## Time to Estimate Parameters:
##  Time difference of 0.03465009 secs
## Warning: Using formula(x) is deprecated when x is a character vector of length > 1.
##   Consider formula(paste(x, collapse = " ")) instead.
## 
## Title:
##  GARCH Modelling 
## 
## Call:
##  garchFit(formula = ~arma(1, 0) + garch(1, 0), data = diff(log(gnp))) 
## 
## Mean and Variance Equation:
##  data ~ arma(1, 0) + garch(1, 0)
## <environment: 0x55f4c8efc0b8>
##  [data = diff(log(gnp))]
## 
## Conditional Distribution:
##  norm 
## 
## Coefficient(s):
##         mu         ar1       omega      alpha1  
## 0.00527795  0.36656253  0.00007331  0.19447135  
## 
## Std. Errors:
##  based on Hessian 
## 
## Error Analysis:
##         Estimate  Std. Error  t value Pr(>|t|)    
## mu     5.278e-03   8.996e-04    5.867 4.44e-09 ***
## ar1    3.666e-01   7.514e-02    4.878 1.07e-06 ***
## omega  7.331e-05   9.011e-06    8.135 4.44e-16 ***
## alpha1 1.945e-01   9.554e-02    2.035   0.0418 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Log Likelihood:
##  722.2849    normalized:  3.253536 
## 
## Description:
##  Fri Mar 19 21:40:28 2021 by user: ryan 
## 
## 
## Standardised Residuals Tests:
##                                 Statistic p-Value    
##  Jarque-Bera Test   R    Chi^2  9.118036  0.01047234 
##  Shapiro-Wilk Test  R    W      0.9842406 0.0143365  
##  Ljung-Box Test     R    Q(10)  9.874326  0.4515875  
##  Ljung-Box Test     R    Q(15)  17.55855  0.2865844  
##  Ljung-Box Test     R    Q(20)  23.41363  0.2689437  
##  Ljung-Box Test     R^2  Q(10)  19.2821   0.03682245 
##  Ljung-Box Test     R^2  Q(15)  33.23648  0.004352733
##  Ljung-Box Test     R^2  Q(20)  37.74259  0.009518984
##  LM Arch Test       R    TR^2   25.41625  0.01296901 
## 
## Information Criterion Statistics:
##       AIC       BIC       SIC      HQIC 
## -6.471035 -6.409726 -6.471669 -6.446282
# garch(1,0) specifies an ARCH(1) in the code below (details later).

Example 5.5 Garch Analysis of the DJIA Returns

library(xts)
djiar = diff(log(djia$Close))[-1]
acf2(djiar)
 # exhibits some autocorrelation (not shown)
acf2(djiar^2)
 # oozes autocorrelation (not shown)
library(fGarch)
summary(djia.g <- garchFit(~arma(1,0)+garch(1,1), data=djiar,
cond.dist='std'))
plot(djia.g)
 # to see all plot options

Example 5.6 APARCH Analysis of the DJIA Returns

library(xts)
library(fGarch)
summary(djia.ap <- garchFit(~arma(1,0)+aparch(1,1), data=djiar,
cond.dist='std'))
plot(djia.ap)

5.4 Threshold Models

For stationary series, we learned in Section 3.4 that forward predicition is the same as backward prediction. This is because the variance-covariance matrix of \(x_{1:n} = (x_1, \dots, x_n)\) is the same as the variance-covariance matrix of \(x_{n:1}\). If the process is stationary Gaussian, then the distribution of \(x_{1:n}\) is identical to the distribution of \(x_{n:1}\).

However, many series do not fit into this category. Example of inmfluenza deaths per 10,000 in the US from 1968 to 1978. Typically, the number of deaths tends to increase faster than it decreases, especially during epidemics. Therefore, data plotted back in time would tend to increase slower than it decreases. (You could still account for this with a model, but not a stationary model.) Also, linear Gaussian processes do not have large bursts of positive and negative changes that occur periodically in this series.

The data are also not perfectly seasonal. The peak is typically in January but sometimes occurs in February or March. Hence seasonal ARMA models would not capture this behavior (something to think about for my modeling…).

So, this would be a nonlinear time series. There are many modeling approaches that could use, but focus on threshold ARMA models (TARMA) here. The basic idea is of fitting local linear ARMA models.

Example 5.7 Threshold Modeling of the Influenza Series

\(x_t = flu_t - flu_{t-1}\)

#install.packages("tsDyn")
plot(flu, type="c")
Months = c("J","F","M","A","M","J","J","A","S","O","N","D")
points(flu, pch=Months, cex=.8, font=2)

# Start analysis
dflu = diff(flu)
lag1.plot(dflu, corr=FALSE)

 # scatterplot with lowess fit
thrsh = .05
 # threshold
Z = ts.intersect(dflu, lag(dflu,-1), lag(dflu,-2), lag(dflu,-3),
lag(dflu,-4) )
ind1 = ifelse(Z[,2] < thrsh, 1, NA) # indicator < thrsh
ind2 = ifelse(Z[,2] < thrsh, NA, 1) # indicator >= thrsh
X1 = Z[,1]*ind1
X2 = Z[,1]*ind2
summary(fit1 <- lm(X1~ Z[,2:5]) )
## 
## Call:
## lm(formula = X1 ~ Z[, 2:5])
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -0.13312 -0.02049  0.00218  0.01667  0.26666 
## 
## Coefficients:
##                        Estimate Std. Error t value Pr(>|t|)    
## (Intercept)            0.004471   0.004894   0.914 0.363032    
## Z[, 2:5]lag(dflu, -1)  0.506650   0.078319   6.469  3.2e-09 ***
## Z[, 2:5]lag(dflu, -2) -0.200086   0.056573  -3.537 0.000604 ***
## Z[, 2:5]lag(dflu, -3)  0.121047   0.054463   2.223 0.028389 *  
## Z[, 2:5]lag(dflu, -4) -0.110938   0.045979  -2.413 0.017564 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.04578 on 105 degrees of freedom
##   (17 observations deleted due to missingness)
## Multiple R-squared:  0.3763, Adjusted R-squared:  0.3526 
## F-statistic: 15.84 on 4 and 105 DF,  p-value: 3.568e-10
 # case 1
summary(fit2 <- lm(X2~ Z[,2:5]) )
## 
## Call:
## lm(formula = X2 ~ Z[, 2:5])
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -0.089975 -0.036825 -0.006328  0.040765  0.129509 
## 
## Coefficients:
##                       Estimate Std. Error t value Pr(>|t|)    
## (Intercept)            0.40794    0.04675   8.726 1.53e-06 ***
## Z[, 2:5]lag(dflu, -1) -0.74833    0.16644  -4.496 0.000732 ***
## Z[, 2:5]lag(dflu, -2) -1.03231    0.21137  -4.884 0.000376 ***
## Z[, 2:5]lag(dflu, -3) -2.04504    1.05000  -1.948 0.075235 .  
## Z[, 2:5]lag(dflu, -4) -6.71178    1.24538  -5.389 0.000163 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.0721 on 12 degrees of freedom
##   (110 observations deleted due to missingness)
## Multiple R-squared:  0.9207, Adjusted R-squared:  0.8943 
## F-statistic: 34.85 on 4 and 12 DF,  p-value: 1.618e-06
 # case 2
D = cbind(rep(1, nrow(Z)), Z[,2:5])
 # design matrix
p1 = D %*% coef(fit1)
 # get predictions
p2 = D %*% coef(fit2)
prd = ifelse(Z[,2] < thrsh, p1, p2)
plot(dflu, ylim=c(-.5,.5), type='p', pch=3)
lines(prd)
prde1 = sqrt(sum(resid(fit1)^2)/df.residual(fit1) )
prde2 = sqrt(sum(resid(fit2)^2)/df.residual(fit2) )
prde = ifelse(Z[,2] < thrsh, prde1, prde2)
tx = time(dflu)[-(1:4)]
xx = c(tx, rev(tx))
yy = c(prd-2*prde, rev(prd+2*prde))
polygon(xx, yy, border=8, col=gray(.6, alpha=.25) )
abline(h=.05, col=4, lty=6)

library(tsDyn)
 # load package - install it if you don't have it
# vignette("tsDyn") # for package details
(u = setar(dflu, m=4, thDelay=0, th=.05)) # fit model and view results
## Warning: 
## With the threshold you gave (0.05) there is a regime with less than trim=15% observations (86.61%, 13.39%, )
## 
##  1 T: Trim not respected:  0.8661417 0.1338583 from th: 0.05
## Warning: Possible unit root in the high regime. Roots are: 0.6182 0.6244 0.6244
## 0.6182
## 
## Non linear autoregressive model
## 
## SETAR model ( 2 regimes)
## Coefficients:
## Low regime:
##      const.L       phiL.1       phiL.2       phiL.3       phiL.4 
##  0.004471044  0.506649694 -0.200086031  0.121047354 -0.110938271 
## 
## High regime:
##    const.H     phiH.1     phiH.2     phiH.3     phiH.4 
##  0.4079353 -0.7483325 -1.0323129 -2.0450407 -6.7117769 
## 
## Threshold:
## -Variable: Z(t) = + (1) X(t)+ (0)X(t-1)+ (0)X(t-2)+ (0)X(t-3)
## -Value: 0.05 (fixed)
## Proportion of points in low regime: 86.61%    High regime: 13.39%
(u = setar(dflu, m=4, thDelay=0))
## Warning: Possible unit root in the high regime. Roots are: 0.8074 0.8074 1.3596
## 1.3596
## 
## Non linear autoregressive model
## 
## SETAR model ( 2 regimes)
## Coefficients:
## Low regime:
##       const.L        phiL.1        phiL.2        phiL.3        phiL.4 
##  0.0006269563  0.4608089284 -0.2243720404  0.1100931813 -0.1307031988 
## 
## High regime:
##    const.H     phiH.1     phiH.2     phiH.3     phiH.4 
##  0.2035231 -0.4071318 -1.4686776  0.3768388 -0.8298225 
## 
## Threshold:
## -Variable: Z(t) = + (1) X(t)+ (0)X(t-1)+ (0)X(t-2)+ (0)X(t-3)
## -Value: 0.03646
## Proportion of points in low regime: 84.25%    High regime: 15.75%
 # let program fit threshold (=.036)
BIC(u); AIC(u)
## [1] -678.5372
## [1] -710.1644
 # if you want to try other models; m=3 works well too
plot(u)

 # graphics - ?plot.setar for information

5.5 Lagged Regression and Transfer Function Modeling

Example 5.8 Relating the Prewhitened SOI to the transformed recruitment series

soi.d = resid(lm(soi~time(soi), na.action=NULL)) # detrended SOI
acf2(soi.d)

##      [,1] [,2]  [,3]  [,4]  [,5]  [,6]  [,7]  [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.59 0.35  0.18  0.01 -0.15 -0.23 -0.22 -0.14 0.01  0.19  0.33  0.38  0.28
## PACF 0.59 0.00 -0.03 -0.12 -0.16 -0.08  0.01  0.07 0.15  0.18  0.16  0.06 -0.11
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF   0.07 -0.10 -0.22 -0.35 -0.43 -0.38 -0.24 -0.08  0.11  0.28  0.32  0.22
## PACF -0.25 -0.15 -0.06 -0.06 -0.07  0.01  0.02  0.01  0.06  0.10  0.04 -0.05
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.06 -0.07 -0.20 -0.32 -0.42 -0.36 -0.20 -0.05  0.15  0.32  0.38  0.29
## PACF -0.11 -0.04 -0.04 -0.05 -0.11 -0.01  0.04 -0.03  0.07  0.10  0.08 -0.01
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF   0.15 -0.02 -0.16 -0.27 -0.30 -0.28 -0.16  0.04  0.20  0.37  0.40
## PACF -0.05 -0.10 -0.04  0.00  0.07 -0.01 -0.02  0.02 -0.02  0.09  0.01
fit = arima(soi.d, order=c(1,0,0))
ar1 = as.numeric(coef(fit)[1])
 # = 0.5875
soi.pw = resid(fit)
rec.fil = filter(rec, filter=c(1, -ar1), sides=1)
ccf(soi.pw, rec.fil, ylab="CCF", na.action=na.omit, panel.first=grid())

Example 5.9 Transfer Function Model for SOI and Recruitment

soi.d = resid(lm(soi~time(soi), na.action=NULL))
fish = ts.intersect(rec, RL1=lag(rec,-1), SL5=lag(soi.d,-5))
(u = lm(fish[,1]~fish[,2:3], na.action=NULL))
## 
## Call:
## lm(formula = fish[, 1] ~ fish[, 2:3], na.action = NULL)
## 
## Coefficients:
##    (Intercept)  fish[, 2:3]RL1  fish[, 2:3]SL5  
##         8.9022          0.8557        -20.3836
acf2(resid(u))

##      [,1]  [,2]  [,3]  [,4]  [,5] [,6]  [,7] [,8]  [,9] [,10] [,11] [,12] [,13]
## ACF   0.4  0.09 -0.04 -0.15 -0.02 0.07 -0.01 0.01 -0.06 -0.10 -0.09 -0.09 -0.09
## PACF  0.4 -0.08 -0.06 -0.13  0.11 0.05 -0.09 0.04 -0.06 -0.04 -0.05 -0.04 -0.06
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.06 -0.07 -0.07  0.01  0.01 -0.02 -0.02  0.01  0.03  0.04  0.02  0.00
## PACF -0.03 -0.05 -0.04  0.05 -0.03 -0.04 -0.03  0.05 -0.01 -0.02 -0.01 -0.02
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.03  0.08  0.06  0.08  0.05 -0.01 -0.12 -0.12 -0.02  0.07  0.11  0.08
## PACF  0.03  0.06  0.00  0.04  0.01 -0.01 -0.14 -0.01  0.06  0.05  0.03  0.03
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF  -0.07 -0.12 -0.02  0.06  0.09  0.05  0.00 -0.08 -0.08 -0.03  0.02
## PACF -0.09 -0.04  0.10  0.07  0.01 -0.03  0.01 -0.07 -0.01  0.02  0.01
 # suggests ar1
(arx = sarima(fish[,1], 1, 0, 0, xreg=fish[,2:3]))
## initial  value 2.050304 
## iter   2 value 1.963124
## iter   3 value 1.961582
## iter   4 value 1.956228
## iter   5 value 1.955996
## iter   6 value 1.955717
## iter   7 value 1.955565
## iter   8 value 1.955539
## iter   9 value 1.955536
## iter  10 value 1.955536
## iter  10 value 1.955536
## final  value 1.955536 
## converged
## initial  value 1.956081 
## iter   2 value 1.956079
## iter   3 value 1.956073
## iter   4 value 1.956072
## iter   5 value 1.956072
## iter   6 value 1.956072
## iter   7 value 1.956072
## iter   7 value 1.956072
## iter   7 value 1.956072
## final  value 1.956072 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1  intercept     RL1       SL5
##       0.4503    12.3402  0.8001  -21.0607
## s.e.  0.0506     1.5796  0.0235    1.0926
## 
## sigma^2 estimated as 49.98:  log likelihood = -1505.25,  aic = 3020.51
## 
## $degrees_of_freedom
## [1] 442
## 
## $ttable
##           Estimate     SE  t.value p.value
## ar1         0.4503 0.0506   8.9009       0
## intercept  12.3402 1.5796   7.8124       0
## RL1         0.8001 0.0235  34.0715       0
## SL5       -21.0607 1.0926 -19.2752       0
## 
## $AIC
## [1] 6.772442
## 
## $AICc
## [1] 6.772646
## 
## $BIC
## [1] 6.81841
 # final model

pred = rec + resid(arx$fit)
 # 1-step-ahead predictions
ts.plot(pred, rec, col=c('gray90',1), lwd=c(7,1))

5.6 Multivariate ARMAX Models

Example 5.10 Pollution Weather and Mortality

library(vars)
## Loading required package: MASS
## Loading required package: strucchange
## Loading required package: sandwich
## Loading required package: urca
## Loading required package: lmtest
x = cbind(cmort, tempr, part)
summary(VAR(x, p=1, type='both'))
## 
## VAR Estimation Results:
## ========================= 
## Endogenous variables: cmort, tempr, part 
## Deterministic variables: both 
## Sample size: 507 
## Log Likelihood: -5116.02 
## Roots of the characteristic polynomial:
## 0.8931 0.4953 0.1444
## Call:
## VAR(y = x, p = 1, type = "both")
## 
## 
## Estimation results for equation cmort: 
## ====================================== 
## cmort = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1  0.464824   0.036729  12.656  < 2e-16 ***
## tempr.l1 -0.360888   0.032188 -11.212  < 2e-16 ***
## part.l1   0.099415   0.019178   5.184 3.16e-07 ***
## const    73.227292   4.834004  15.148  < 2e-16 ***
## trend    -0.014459   0.001978  -7.308 1.07e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 5.583 on 502 degrees of freedom
## Multiple R-Squared: 0.6908,  Adjusted R-squared: 0.6883 
## F-statistic: 280.3 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation tempr: 
## ====================================== 
## tempr = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1 -0.244046   0.042105  -5.796 1.20e-08 ***
## tempr.l1  0.486596   0.036899  13.187  < 2e-16 ***
## part.l1  -0.127661   0.021985  -5.807 1.13e-08 ***
## const    67.585598   5.541550  12.196  < 2e-16 ***
## trend    -0.006912   0.002268  -3.048  0.00243 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 6.4 on 502 degrees of freedom
## Multiple R-Squared: 0.5007,  Adjusted R-squared: 0.4967 
## F-statistic: 125.9 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation part: 
## ===================================== 
## part = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1 -0.124775   0.079013  -1.579    0.115    
## tempr.l1 -0.476526   0.069245  -6.882 1.77e-11 ***
## part.l1   0.581308   0.041257  14.090  < 2e-16 ***
## const    67.463501  10.399163   6.487 2.10e-10 ***
## trend    -0.004650   0.004256  -1.093    0.275    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 12.01 on 502 degrees of freedom
## Multiple R-Squared: 0.3732,  Adjusted R-squared: 0.3683 
## F-statistic: 74.74 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## 
## Covariance matrix of residuals:
##        cmort  tempr   part
## cmort 31.172  5.975  16.65
## tempr  5.975 40.965  42.32
## part  16.654 42.323 144.26
## 
## Correlation matrix of residuals:
##        cmort  tempr   part
## cmort 1.0000 0.1672 0.2484
## tempr 0.1672 1.0000 0.5506
## part  0.2484 0.5506 1.0000
 # 'both' fits constant + trend

Example 5.11 Pollution Weather and Mortality

VARselect(x, lag.max=10, type="both")
## $selection
## AIC(n)  HQ(n)  SC(n) FPE(n) 
##      9      5      2      9 
## 
## $criteria
##                   1           2           3           4           5           6
## AIC(n)     11.73780    11.30185    11.26788    11.23030    11.17634    11.15266
## HQ(n)      11.78758    11.38149    11.37738    11.36967    11.34557    11.35176
## SC(n)      11.86463    11.50477    11.54689    11.58541    11.60755    11.65996
## FPE(n) 125216.91717 80972.28678 78268.19568 75383.73647 71426.10041 69758.25113
##                  7           8           9          10
## AIC(n)    11.15247    11.12878    11.11915    11.12019
## HQ(n)     11.38144    11.38760    11.40784    11.43874
## SC(n)     11.73587    11.78827    11.85473    11.93187
## FPE(n) 69749.89175 68122.40518 67476.96374 67556.45243
summary(fit <- VAR(x, p=2, type="both")) # partial results displayed
## 
## VAR Estimation Results:
## ========================= 
## Endogenous variables: cmort, tempr, part 
## Deterministic variables: both 
## Sample size: 506 
## Log Likelihood: -4987.186 
## Roots of the characteristic polynomial:
## 0.8807 0.8807 0.5466 0.4746 0.4746 0.4498
## Call:
## VAR(y = x, p = 2, type = "both")
## 
## 
## Estimation results for equation cmort: 
## ====================================== 
## cmort = cmort.l1 + tempr.l1 + part.l1 + cmort.l2 + tempr.l2 + part.l2 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1  0.297059   0.043734   6.792 3.15e-11 ***
## tempr.l1 -0.199510   0.044274  -4.506 8.23e-06 ***
## part.l1   0.042523   0.024034   1.769  0.07745 .  
## cmort.l2  0.276194   0.041938   6.586 1.15e-10 ***
## tempr.l2 -0.079337   0.044679  -1.776  0.07639 .  
## part.l2   0.068082   0.025286   2.692  0.00733 ** 
## const    56.098652   5.916618   9.482  < 2e-16 ***
## trend    -0.011042   0.001992  -5.543 4.84e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 5.295 on 498 degrees of freedom
## Multiple R-Squared: 0.7227,  Adjusted R-squared: 0.7188 
## F-statistic: 185.4 on 7 and 498 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation tempr: 
## ====================================== 
## tempr = cmort.l1 + tempr.l1 + part.l1 + cmort.l2 + tempr.l2 + part.l2 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1 -0.108889   0.050667  -2.149  0.03211 *  
## tempr.l1  0.260963   0.051292   5.088 5.14e-07 ***
## part.l1  -0.050542   0.027844  -1.815  0.07010 .  
## cmort.l2 -0.040870   0.048587  -0.841  0.40065    
## tempr.l2  0.355592   0.051762   6.870 1.93e-11 ***
## part.l2  -0.095114   0.029295  -3.247  0.00125 ** 
## const    49.880485   6.854540   7.277 1.34e-12 ***
## trend    -0.004754   0.002308  -2.060  0.03993 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 6.134 on 498 degrees of freedom
## Multiple R-Squared: 0.5445,  Adjusted R-squared: 0.5381 
## F-statistic: 85.04 on 7 and 498 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation part: 
## ===================================== 
## part = cmort.l1 + tempr.l1 + part.l1 + cmort.l2 + tempr.l2 + part.l2 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1  0.078934   0.091773   0.860 0.390153    
## tempr.l1 -0.388808   0.092906  -4.185 3.37e-05 ***
## part.l1   0.388814   0.050433   7.709 6.92e-14 ***
## cmort.l2 -0.325112   0.088005  -3.694 0.000245 ***
## tempr.l2  0.052780   0.093756   0.563 0.573724    
## part.l2   0.382193   0.053062   7.203 2.19e-12 ***
## const    59.586169  12.415669   4.799 2.11e-06 ***
## trend    -0.007582   0.004180  -1.814 0.070328 .  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 11.11 on 498 degrees of freedom
## Multiple R-Squared: 0.4679,  Adjusted R-squared: 0.4604 
## F-statistic: 62.57 on 7 and 498 DF,  p-value: < 2.2e-16 
## 
## 
## 
## Covariance matrix of residuals:
##        cmort  tempr   part
## cmort 28.034  7.076  16.33
## tempr  7.076 37.627  40.88
## part  16.325 40.880 123.45
## 
## Correlation matrix of residuals:
##        cmort  tempr   part
## cmort 1.0000 0.2179 0.2775
## tempr 0.2179 1.0000 0.5998
## part  0.2775 0.5998 1.0000
acf(resid(fit), 52)

serial.test(fit, lags.pt=12, type="PT.adjusted")
## 
##  Portmanteau Test (adjusted)
## 
## data:  Residuals of VAR object fit
## Chi-squared = 162.35, df = 90, p-value = 4.602e-06
(fit.pr = predict(fit, n.ahead = 24, ci = 0.95))
## $cmort
##           fcst    lower     upper       CI
##  [1,] 87.26921 76.89173  97.64668 10.37748
##  [2,] 87.02842 76.09665  97.96020 10.93178
##  [3,] 87.29573 75.40528  99.18618 11.89045
##  [4,] 87.32528 74.90938  99.74119 12.41591
##  [5,] 87.28237 74.33199 100.23275 12.95038
##  [6,] 87.17621 73.74964 100.60277 13.42657
##  [7,] 87.00116 73.11597 100.88634 13.88519
##  [8,] 86.78430 72.46755 101.10104 14.31674
##  [9,] 86.53258 71.81185 101.25330 14.72073
## [10,] 86.25716 71.16321 101.35111 15.09395
## [11,] 85.96792 70.53387 101.40197 15.43405
## [12,] 85.67068 69.93014 101.41121 15.74053
## [13,] 85.37231 69.35882 101.38580 16.01349
## [14,] 85.07662 68.82233 101.33091 16.25429
## [15,] 84.78756 68.32281 101.25230 16.46474
## [16,] 84.50751 67.86030 101.15472 16.64721
## [17,] 84.23850 67.43429 101.04272 16.80422
## [18,] 83.98179 67.04340 100.92019 16.93840
## [19,] 83.73823 66.68589 100.79057 17.05234
## [20,] 83.50824 66.35971 100.65678 17.14853
## [21,] 83.29196 66.06268 100.52125 17.22929
## [22,] 83.08928 65.79254 100.38601 17.29673
## [23,] 82.89988 65.54709 100.25266 17.35279
## [24,] 82.72333 65.32418 100.12248 17.39915
## 
## $tempr
##           fcst    lower    upper       CI
##  [1,] 70.33437 58.31182 82.35692 12.02255
##  [2,] 69.09470 56.77089 81.41851 12.32381
##  [3,] 69.22457 56.09460 82.35454 13.12997
##  [4,] 68.83591 55.32996 82.34186 13.50595
##  [5,] 69.01016 55.04606 82.97425 13.96409
##  [6,] 69.02784 54.66842 83.38726 14.35942
##  [7,] 69.24058 54.48088 84.00028 14.75970
##  [8,] 69.42757 54.29875 84.55638 15.12882
##  [9,] 69.67548 54.19959 85.15137 15.47589
## [10,] 69.92480 54.13266 85.71694 15.79214
## [11,] 70.18945 54.11108 86.26782 16.07837
## [12,] 70.45350 54.11980 86.78720 16.33370
## [13,] 70.71606 54.15682 87.27531 16.55925
## [14,] 70.97206 54.21547 87.72865 16.75659
## [15,] 71.21930 54.29151 88.14710 16.92780
## [16,] 71.45577 54.38057 88.53098 17.07521
## [17,] 71.68018 54.47895 88.88141 17.20123
## [18,] 71.89173 54.58344 89.20001 17.30829
## [19,] 72.08997 54.69128 89.48865 17.39868
## [20,] 72.27479 54.80021 89.74938 17.47459
## [21,] 72.44632 54.90833 89.98430 17.53798
## [22,] 72.60484 55.01416 90.19551 17.59068
## [23,] 72.75079 55.11652 90.38505 17.63426
## [24,] 72.88470 55.21454 90.55486 17.67016
## 
## $part
##           fcst    lower    upper       CI
##  [1,] 56.20206 34.42555 77.97858 21.77651
##  [2,] 56.97066 34.09865 79.84267 22.87201
##  [3,] 54.68760 29.56147 79.81373 25.12613
##  [4,] 54.06954 27.96958 80.16950 26.09996
##  [5,] 53.02247 26.03038 80.01457 26.99209
##  [6,] 52.27031 24.64432 79.89629 27.62598
##  [7,] 51.57798 23.45803 79.69794 28.11995
##  [8,] 50.95265 22.44679 79.45851 28.50586
##  [9,] 50.41566 21.61341 79.21791 28.80225
## [10,] 49.92440 20.88946 78.95934 29.03494
## [11,] 49.49682 20.28223 78.71141 29.21459
## [12,] 49.11220 19.75756 78.46685 29.35465
## [13,] 48.77353 19.31057 78.23649 29.46296
## [14,] 48.47221 18.92535 78.01907 29.54686
## [15,] 48.20602 18.59443 77.81761 29.61159
## [16,] 47.97048 18.30903 77.63193 29.66145
## [17,] 47.76256 18.06281 77.46231 29.69975
## [18,] 47.57915 17.85006 77.30824 29.72909
## [19,] 47.41758 17.66608 77.16908 29.75150
## [20,] 47.27540 17.50683 77.04398 29.76857
## [21,] 47.15042 17.36888 76.93196 29.78154
## [22,] 47.04067 17.24932 76.83202 29.79135
## [23,] 46.94438 17.14563 76.74314 29.79875
## [24,] 46.85998 17.05566 76.66431 29.80432
 # 4 weeks ahead
fanchart(fit.pr) # plot prediction + error

Example 5.12 The Spliid Algorithm for Fitting Vector ARMA

# install.packages("marima")
library(marima)
model = define.model(kvar=3, ar=c(1,2), ma=c(1))
arp = model$ar.pattern; map = model$ma.pattern
cmort.d = resid(detr <- lm(cmort~ time(cmort), na.action=NULL))
xdata = matrix(cbind(cmort.d, tempr, part), ncol=3) # strip ts attributes
fit = marima(xdata, ar.pattern=arp, ma.pattern=map, means=c(0,1,1),
penalty=1)
## All cases in data,  1  to  508  accepted for completeness.
## 508 3  = MARIMA - dimension of data
innov = t(resid(fit)); plot.ts(innov); acf(innov, na.action=na.pass)

# fitted values for cmort
pred = ts(t(fitted(fit))[,1], start=start(cmort), freq=frequency(cmort)) +
detr$coef[1] + detr$coef[2]*time(cmort)
plot(pred, ylab="Cardiovascular Mortality", lwd=2, col=4); points(cmort)

# print estimates and corresponding t^2-statistic
short.form(fit$ar.estimates, leading=FALSE)
## , , Lag=1
## 
##        x1=y1     x2=y2     x3=y3
## y1 -0.311106  0.000000 -0.113831
## y2  0.000000 -0.656331  0.048208
## y3 -0.108892  0.000000 -0.860911
## 
## , , Lag=2
## 
##        x1=y1     x2=y2     x3=y3
## y1 -0.333368  0.132523 -0.047171
## y2  0.000000 -0.200135  0.054616
## y3  0.179117 -0.102144 -0.151250
short.form(fit$ar.fvalues,
 leading=FALSE)
## , , Lag=1
## 
##        x1=y1    x2=y2      x3=y3
## y1 51.211590  0.00000   7.909997
## y2  0.000000 41.73927   3.141522
## y3  1.571085  0.00000 113.299823
## 
## , , Lag=2
## 
##        x1=y1     x2=y2    x3=y3
## y1 67.241600 11.890684 2.515931
## y2  0.000000  8.101381 2.903037
## y3  4.860958  1.768893 6.477311
short.form(fit$ma.estimates, leading=FALSE)
## , , Lag=1
## 
##        x1=y1     x2=y2     x3=y3
## y1  0.000000 -0.186710 -0.106470
## y2 -0.114446 -0.446431  0.000000
## y3  0.000000 -0.278378 -0.672962
short.form(fit$ma.fvalues,
 leading=FALSE)
## , , Lag=1
## 
##       x1=y1     x2=y2    x3=y3
## y1 0.000000 14.514812  4.75441
## y2 4.683436 16.375957  0.00000
## y3 0.000000  8.079861 47.56415
fit$resid.cov
##           u1        u2        u3
## u1 27.346796  6.503133  13.79950
## u2  6.503133 36.202990  38.12202
## u3 13.799495 38.122018 109.20702
 # estimate of noise cov matrix


#

5.2 Unit Root Testing

Example 5.3 Testing Unit Roots in the Glacial Varve Series

library(tseries)
adf.test(log(varve), k=0) # DF test
## Warning in adf.test(log(varve), k = 0): p-value smaller than printed p-value
## 
##  Augmented Dickey-Fuller Test
## 
## data:  log(varve)
## Dickey-Fuller = -12.857, Lag order = 0, p-value = 0.01
## alternative hypothesis: stationary
# Dickey-Fuller = -12.8572, Lag order = 0, p-value < 0.01
# alternative hypothesis: stationary
adf.test(log(varve)) # ADF test
## 
##  Augmented Dickey-Fuller Test
## 
## data:  log(varve)
## Dickey-Fuller = -3.5166, Lag order = 8, p-value = 0.04071
## alternative hypothesis: stationary
#Dickey-Fuller = -3.5166, Lag order = 8, p-value = 0.04071
# alternative hypothesis: stationary
pp.test(log(varve)) # PP test
## Warning in pp.test(log(varve)): p-value smaller than printed p-value
## 
##  Phillips-Perron Unit Root Test
## 
## data:  log(varve)
## Dickey-Fuller Z(alpha) = -304.54, Truncation lag parameter = 6, p-value
## = 0.01
## alternative hypothesis: stationary
# Dickey-Fuller Z(alpha) = -304.5376,
# Truncation lag parameter = 6, p-value < 0.01
# alternative hypothesis: stationary

5.3 GARCH Models

Example 5.4 Analysis of US GNP

u = sarima(diff(log(gnp)), 1, 0, 0)
## initial  value -4.589567 
## iter   2 value -4.654150
## iter   3 value -4.654150
## iter   4 value -4.654151
## iter   4 value -4.654151
## iter   4 value -4.654151
## final  value -4.654151 
## converged
## initial  value -4.655919 
## iter   2 value -4.655921
## iter   3 value -4.655922
## iter   4 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## iter   5 value -4.655922
## final  value -4.655922 
## converged

acf2(resid(u$fit)^2, 20)

##      [,1] [,2] [,3] [,4]  [,5] [,6]  [,7] [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.12 0.13 0.03 0.13  0.01 0.05 -0.03 0.06 0.08 -0.08  0.09  0.10  0.01
## PACF 0.12 0.12 0.00 0.12 -0.02 0.02 -0.04 0.05 0.08 -0.12  0.11  0.09 -0.05
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20]
## ACF   0.04  0.15 -0.02  0.04 -0.05  0.01  0.05
## PACF  0.05  0.13 -0.09  0.01 -0.05  0.00  0.04
library(fGarch)
summary(garchFit(~arma(1,0)+garch(1,0), diff(log(gnp))))
## 
## Series Initialization:
##  ARMA Model:                arma
##  Formula Mean:              ~ arma(1, 0)
##  GARCH Model:               garch
##  Formula Variance:          ~ garch(1, 0)
##  ARMA Order:                1 0
##  Max ARMA Order:            1
##  GARCH Order:               1 0
##  Max GARCH Order:           1
##  Maximum Order:             1
##  Conditional Dist:          norm
##  h.start:                   2
##  llh.start:                 1
##  Length of Series:          222
##  Recursion Init:            mci
##  Series Scale:              0.01015924
## 
## Parameter Initialization:
##  Initial Parameters:          $params
##  Limits of Transformations:   $U, $V
##  Which Parameters are Fixed?  $includes
##  Parameter Matrix:
##                      U          V    params includes
##     mu     -8.20681904   8.206819 0.8205354     TRUE
##     ar1    -0.99999999   1.000000 0.3466459     TRUE
##     omega   0.00000100 100.000000 0.1000000     TRUE
##     alpha1  0.00000001   1.000000 0.1000000     TRUE
##     gamma1 -0.99999999   1.000000 0.1000000    FALSE
##     delta   0.00000000   2.000000 2.0000000    FALSE
##     skew    0.10000000  10.000000 1.0000000    FALSE
##     shape   1.00000000  10.000000 4.0000000    FALSE
##  Index List of Parameters to be Optimized:
##     mu    ar1  omega alpha1 
##      1      2      3      4 
##  Persistence:                  0.1 
## 
## 
## --- START OF TRACE ---
## Selected Algorithm: nlminb 
## 
## R coded nlminb Solver: 
## 
##   0:     682.89527: 0.820535 0.346646 0.100000 0.100000
##   1:     308.43148: 0.763492 0.258112  1.06104 0.352453
##   2:     306.07332: 0.681276 0.195897  1.04763 0.304072
##   3:     301.00807: 0.561958 0.448458 0.825277 0.0402737
##   4:     298.88361: 0.383716 0.465477 0.632947 0.385969
##   5:     296.74288: 0.504144 0.389445 0.683634 0.247795
##   6:     296.67703: 0.497724 0.366843 0.688130 0.229496
##   7:     296.60039: 0.500011 0.385702 0.703145 0.211105
##   8:     296.59692: 0.515645 0.374174 0.690079 0.194961
##   9:     296.56381: 0.513570 0.367018 0.702272 0.200013
##  10:     296.55723: 0.523440 0.363125 0.708406 0.194152
##  11:     296.55632: 0.522578 0.364912 0.710103 0.194839
##  12:     296.55598: 0.520871 0.364956 0.710924 0.193212
##  13:     296.55568: 0.519486 0.366572 0.710213 0.194509
##  14:     296.55568: 0.519508 0.366596 0.710266 0.194513
##  15:     296.55568: 0.519511 0.366586 0.710289 0.194454
##  16:     296.55568: 0.519505 0.366563 0.710298 0.194465
##  17:     296.55568: 0.519526 0.366560 0.710295 0.194472
##  18:     296.55568: 0.519522 0.366563 0.710295 0.194471
## 
## Final Estimate of the Negative LLH:
##  LLH:  -722.2849    norm LLH:  -3.253536 
##           mu          ar1        omega       alpha1 
## 0.0052779473 0.3665625267 0.0000733096 0.1944713494 
## 
## R-optimhess Difference Approximated Hessian Matrix:
##                  mu           ar1         omega        alpha1
## mu     -2749495.312 -24170.124266  4.546826e+06 -1.586691e+03
## ar1      -24170.124   -390.266806  1.253875e+04 -6.733799e+00
## omega   4546825.892  12538.746433 -1.590043e+10 -7.069340e+05
## alpha1    -1586.691     -6.733799 -7.069340e+05 -1.425395e+02
## attr(,"time")
## Time difference of 0.004212379 secs
## 
## --- END OF TRACE ---
## 
## 
## Time to Estimate Parameters:
##  Time difference of 0.01934505 secs
## Warning: Using formula(x) is deprecated when x is a character vector of length > 1.
##   Consider formula(paste(x, collapse = " ")) instead.
## 
## Title:
##  GARCH Modelling 
## 
## Call:
##  garchFit(formula = ~arma(1, 0) + garch(1, 0), data = diff(log(gnp))) 
## 
## Mean and Variance Equation:
##  data ~ arma(1, 0) + garch(1, 0)
## <environment: 0x55f4cd120638>
##  [data = diff(log(gnp))]
## 
## Conditional Distribution:
##  norm 
## 
## Coefficient(s):
##         mu         ar1       omega      alpha1  
## 0.00527795  0.36656253  0.00007331  0.19447135  
## 
## Std. Errors:
##  based on Hessian 
## 
## Error Analysis:
##         Estimate  Std. Error  t value Pr(>|t|)    
## mu     5.278e-03   8.996e-04    5.867 4.44e-09 ***
## ar1    3.666e-01   7.514e-02    4.878 1.07e-06 ***
## omega  7.331e-05   9.011e-06    8.135 4.44e-16 ***
## alpha1 1.945e-01   9.554e-02    2.035   0.0418 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Log Likelihood:
##  722.2849    normalized:  3.253536 
## 
## Description:
##  Fri Mar 19 21:40:33 2021 by user: ryan 
## 
## 
## Standardised Residuals Tests:
##                                 Statistic p-Value    
##  Jarque-Bera Test   R    Chi^2  9.118036  0.01047234 
##  Shapiro-Wilk Test  R    W      0.9842406 0.0143365  
##  Ljung-Box Test     R    Q(10)  9.874326  0.4515875  
##  Ljung-Box Test     R    Q(15)  17.55855  0.2865844  
##  Ljung-Box Test     R    Q(20)  23.41363  0.2689437  
##  Ljung-Box Test     R^2  Q(10)  19.2821   0.03682245 
##  Ljung-Box Test     R^2  Q(15)  33.23648  0.004352733
##  Ljung-Box Test     R^2  Q(20)  37.74259  0.009518984
##  LM Arch Test       R    TR^2   25.41625  0.01296901 
## 
## Information Criterion Statistics:
##       AIC       BIC       SIC      HQIC 
## -6.471035 -6.409726 -6.471669 -6.446282

Example 5.5 GARCH Analysis of the DJIA Returns

library(xts)
djiar = diff(log(djia$Close))[-1]
acf2(djiar)
# exhibits some autocorrelation (not shown)
acf2(djiar^2)
# oozes autocorrelation (not shown)
library(fGarch)
summary(djia.g <- garchFit(~arma(1,0)+garch(1,1), data=djiar,
cond.dist='std'))
plot(djia.g)
# to see all plot options

*Example 5.6 APARCH Analysis of the DJIA Returns

p_load(xts, fGarch)
summary(djia.ap <- garchFit(~arma(1,0)+aparch(1,1), data=djiar,
cond.dist='std'))
plot(djia.ap)
# to see all plot options (none shown)

5.4 Threshold Models

Example 5.7 Threshold Modeling of the Influenza Series

plot(flu, type="c")
Months = c("J","F","M","A","M","J","J","A","S","O","N","D")
points(flu, pch=Months, cex=.8, font=2)

# Start analysis
dflu = diff(flu)
lag1.plot(dflu, corr=FALSE)

# scatterplot with lowess fit
thrsh = .05
# threshold
Z= ts.intersect(dflu, lag(dflu,-1), lag(dflu,-2), lag(dflu,-3),
lag(dflu,-4) )
ind1 = ifelse(Z[,2] < thrsh, 1, NA) # indicator < thrsh
ind2 = ifelse(Z[,2] < thrsh, NA, 1) # indicator >= thrsh
X1= Z[,1]*ind1
X2= Z[,1]*ind2
summary(fit1 <- lm(X1~ Z[,2:5]) )
## 
## Call:
## lm(formula = X1 ~ Z[, 2:5])
## 
## Residuals:
##      Min       1Q   Median       3Q      Max 
## -0.13312 -0.02049  0.00218  0.01667  0.26666 
## 
## Coefficients:
##                        Estimate Std. Error t value Pr(>|t|)    
## (Intercept)            0.004471   0.004894   0.914 0.363032    
## Z[, 2:5]lag(dflu, -1)  0.506650   0.078319   6.469  3.2e-09 ***
## Z[, 2:5]lag(dflu, -2) -0.200086   0.056573  -3.537 0.000604 ***
## Z[, 2:5]lag(dflu, -3)  0.121047   0.054463   2.223 0.028389 *  
## Z[, 2:5]lag(dflu, -4) -0.110938   0.045979  -2.413 0.017564 *  
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.04578 on 105 degrees of freedom
##   (17 observations deleted due to missingness)
## Multiple R-squared:  0.3763, Adjusted R-squared:  0.3526 
## F-statistic: 15.84 on 4 and 105 DF,  p-value: 3.568e-10
# case 1
summary(fit2 <- lm(X2~ Z[,2:5]) )
## 
## Call:
## lm(formula = X2 ~ Z[, 2:5])
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -0.089975 -0.036825 -0.006328  0.040765  0.129509 
## 
## Coefficients:
##                       Estimate Std. Error t value Pr(>|t|)    
## (Intercept)            0.40794    0.04675   8.726 1.53e-06 ***
## Z[, 2:5]lag(dflu, -1) -0.74833    0.16644  -4.496 0.000732 ***
## Z[, 2:5]lag(dflu, -2) -1.03231    0.21137  -4.884 0.000376 ***
## Z[, 2:5]lag(dflu, -3) -2.04504    1.05000  -1.948 0.075235 .  
## Z[, 2:5]lag(dflu, -4) -6.71178    1.24538  -5.389 0.000163 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.0721 on 12 degrees of freedom
##   (110 observations deleted due to missingness)
## Multiple R-squared:  0.9207, Adjusted R-squared:  0.8943 
## F-statistic: 34.85 on 4 and 12 DF,  p-value: 1.618e-06
# case 2
D= cbind(rep(1, nrow(Z)), Z[,2:5])
# design matrix
p1= D %*% coef(fit1)
# get predictions
p2= D %*% coef(fit2)
prd= ifelse(Z[,2] < thrsh, p1, p2)
plot(dflu, ylim=c(-.5,.5), type='p', pch=3)
lines(prd)
prde1 = sqrt(sum(resid(fit1)^2)/df.residual(fit1) )
prde2 = sqrt(sum(resid(fit2)^2)/df.residual(fit2) )
prde = ifelse(Z[,2] < thrsh, prde1, prde2)
tx = time(dflu)[-(1:4)]
xx = c(tx, rev(tx))
yy = c(prd-2*prde, rev(prd+2*prde))
polygon(xx, yy, border=8, col=gray(.6, alpha=.25) )
abline(h=.05, col=4, lty=6)

5.5 Lagged Regression and Transfer Function Modeling

Example 5.8 Relating the Prewhitened SOI to the Transformed Recruitment Series

soi.d = resid(lm(soi~time(soi), na.action=NULL)) # detrended SOI
acf2(soi.d)

##      [,1] [,2]  [,3]  [,4]  [,5]  [,6]  [,7]  [,8] [,9] [,10] [,11] [,12] [,13]
## ACF  0.59 0.35  0.18  0.01 -0.15 -0.23 -0.22 -0.14 0.01  0.19  0.33  0.38  0.28
## PACF 0.59 0.00 -0.03 -0.12 -0.16 -0.08  0.01  0.07 0.15  0.18  0.16  0.06 -0.11
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF   0.07 -0.10 -0.22 -0.35 -0.43 -0.38 -0.24 -0.08  0.11  0.28  0.32  0.22
## PACF -0.25 -0.15 -0.06 -0.06 -0.07  0.01  0.02  0.01  0.06  0.10  0.04 -0.05
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.06 -0.07 -0.20 -0.32 -0.42 -0.36 -0.20 -0.05  0.15  0.32  0.38  0.29
## PACF -0.11 -0.04 -0.04 -0.05 -0.11 -0.01  0.04 -0.03  0.07  0.10  0.08 -0.01
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF   0.15 -0.02 -0.16 -0.27 -0.30 -0.28 -0.16  0.04  0.20  0.37  0.40
## PACF -0.05 -0.10 -0.04  0.00  0.07 -0.01 -0.02  0.02 -0.02  0.09  0.01
fit = arima(soi.d, order=c(1,0,0))
ar1 = as.numeric(coef(fit)[1])
# = 0.5875
soi.pw = resid(fit)
rec.fil = filter(rec, filter=c(1, -ar1), sides=1)
ccf(soi.pw, rec.fil, ylab="CCF", na.action=na.omit, panel.first=grid())

Example 5.9 Transfer Function Model for SOI and Recruitment

soi.d = resid(lm(soi~time(soi), na.action=NULL))
fish = ts.intersect(rec, RL1=lag(rec,-1), SL5=lag(soi.d,-5))
(u = lm(fish[,1]~fish[,2:3], na.action=NULL))
## 
## Call:
## lm(formula = fish[, 1] ~ fish[, 2:3], na.action = NULL)
## 
## Coefficients:
##    (Intercept)  fish[, 2:3]RL1  fish[, 2:3]SL5  
##         8.9022          0.8557        -20.3836
acf2(resid(u))

##      [,1]  [,2]  [,3]  [,4]  [,5] [,6]  [,7] [,8]  [,9] [,10] [,11] [,12] [,13]
## ACF   0.4  0.09 -0.04 -0.15 -0.02 0.07 -0.01 0.01 -0.06 -0.10 -0.09 -0.09 -0.09
## PACF  0.4 -0.08 -0.06 -0.13  0.11 0.05 -0.09 0.04 -0.06 -0.04 -0.05 -0.04 -0.06
##      [,14] [,15] [,16] [,17] [,18] [,19] [,20] [,21] [,22] [,23] [,24] [,25]
## ACF  -0.06 -0.07 -0.07  0.01  0.01 -0.02 -0.02  0.01  0.03  0.04  0.02  0.00
## PACF -0.03 -0.05 -0.04  0.05 -0.03 -0.04 -0.03  0.05 -0.01 -0.02 -0.01 -0.02
##      [,26] [,27] [,28] [,29] [,30] [,31] [,32] [,33] [,34] [,35] [,36] [,37]
## ACF   0.03  0.08  0.06  0.08  0.05 -0.01 -0.12 -0.12 -0.02  0.07  0.11  0.08
## PACF  0.03  0.06  0.00  0.04  0.01 -0.01 -0.14 -0.01  0.06  0.05  0.03  0.03
##      [,38] [,39] [,40] [,41] [,42] [,43] [,44] [,45] [,46] [,47] [,48]
## ACF  -0.07 -0.12 -0.02  0.06  0.09  0.05  0.00 -0.08 -0.08 -0.03  0.02
## PACF -0.09 -0.04  0.10  0.07  0.01 -0.03  0.01 -0.07 -0.01  0.02  0.01
# suggests ar1
(arx = sarima(fish[,1], 1, 0, 0, xreg=fish[,2:3]))
## initial  value 2.050304 
## iter   2 value 1.963124
## iter   3 value 1.961582
## iter   4 value 1.956228
## iter   5 value 1.955996
## iter   6 value 1.955717
## iter   7 value 1.955565
## iter   8 value 1.955539
## iter   9 value 1.955536
## iter  10 value 1.955536
## iter  10 value 1.955536
## final  value 1.955536 
## converged
## initial  value 1.956081 
## iter   2 value 1.956079
## iter   3 value 1.956073
## iter   4 value 1.956072
## iter   5 value 1.956072
## iter   6 value 1.956072
## iter   7 value 1.956072
## iter   7 value 1.956072
## iter   7 value 1.956072
## final  value 1.956072 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##          ar1  intercept     RL1       SL5
##       0.4503    12.3402  0.8001  -21.0607
## s.e.  0.0506     1.5796  0.0235    1.0926
## 
## sigma^2 estimated as 49.98:  log likelihood = -1505.25,  aic = 3020.51
## 
## $degrees_of_freedom
## [1] 442
## 
## $ttable
##           Estimate     SE  t.value p.value
## ar1         0.4503 0.0506   8.9009       0
## intercept  12.3402 1.5796   7.8124       0
## RL1         0.8001 0.0235  34.0715       0
## SL5       -21.0607 1.0926 -19.2752       0
## 
## $AIC
## [1] 6.772442
## 
## $AICc
## [1] 6.772646
## 
## $BIC
## [1] 6.81841
# final model
#Coefficients:
#ar1 intercept RL1 SL5
#0.4487 12.3323 0.8005 -21.0307
#s.e. 0.0503 1.5746 0.0234 1.0915
#sigma^2 estimated as 49.93
pred = rec + resid(arx$fit)
# 1-step-ahead predictions
ts.plot(pred, rec, col=c('gray90',1), lwd=c(7,1))

5.6 Multivariate ARMAX Models

*Example 5.10 Pollution Weather and Mortality

library(vars)
x = cbind(cmort, tempr, part)
summary(VAR(x, p=1, type='both'))
## 
## VAR Estimation Results:
## ========================= 
## Endogenous variables: cmort, tempr, part 
## Deterministic variables: both 
## Sample size: 507 
## Log Likelihood: -5116.02 
## Roots of the characteristic polynomial:
## 0.8931 0.4953 0.1444
## Call:
## VAR(y = x, p = 1, type = "both")
## 
## 
## Estimation results for equation cmort: 
## ====================================== 
## cmort = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1  0.464824   0.036729  12.656  < 2e-16 ***
## tempr.l1 -0.360888   0.032188 -11.212  < 2e-16 ***
## part.l1   0.099415   0.019178   5.184 3.16e-07 ***
## const    73.227292   4.834004  15.148  < 2e-16 ***
## trend    -0.014459   0.001978  -7.308 1.07e-12 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 5.583 on 502 degrees of freedom
## Multiple R-Squared: 0.6908,  Adjusted R-squared: 0.6883 
## F-statistic: 280.3 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation tempr: 
## ====================================== 
## tempr = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1 -0.244046   0.042105  -5.796 1.20e-08 ***
## tempr.l1  0.486596   0.036899  13.187  < 2e-16 ***
## part.l1  -0.127661   0.021985  -5.807 1.13e-08 ***
## const    67.585598   5.541550  12.196  < 2e-16 ***
## trend    -0.006912   0.002268  -3.048  0.00243 ** 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 6.4 on 502 degrees of freedom
## Multiple R-Squared: 0.5007,  Adjusted R-squared: 0.4967 
## F-statistic: 125.9 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## Estimation results for equation part: 
## ===================================== 
## part = cmort.l1 + tempr.l1 + part.l1 + const + trend 
## 
##           Estimate Std. Error t value Pr(>|t|)    
## cmort.l1 -0.124775   0.079013  -1.579    0.115    
## tempr.l1 -0.476526   0.069245  -6.882 1.77e-11 ***
## part.l1   0.581308   0.041257  14.090  < 2e-16 ***
## const    67.463501  10.399163   6.487 2.10e-10 ***
## trend    -0.004650   0.004256  -1.093    0.275    
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## 
## Residual standard error: 12.01 on 502 degrees of freedom
## Multiple R-Squared: 0.3732,  Adjusted R-squared: 0.3683 
## F-statistic: 74.74 on 4 and 502 DF,  p-value: < 2.2e-16 
## 
## 
## 
## Covariance matrix of residuals:
##        cmort  tempr   part
## cmort 31.172  5.975  16.65
## tempr  5.975 40.965  42.32
## part  16.654 42.323 144.26
## 
## Correlation matrix of residuals:
##        cmort  tempr   part
## cmort 1.0000 0.1672 0.2484
## tempr 0.1672 1.0000 0.5506
## part  0.2484 0.5506 1.0000
# 'both' fits constant + trend

Example 5.11 Pollution, Weather and Mortality continued

VARselect(x, lag.max=10, type="both")
## $selection
## AIC(n)  HQ(n)  SC(n) FPE(n) 
##      9      5      2      9 
## 
## $criteria
##                   1           2           3           4           5           6
## AIC(n)     11.73780    11.30185    11.26788    11.23030    11.17634    11.15266
## HQ(n)      11.78758    11.38149    11.37738    11.36967    11.34557    11.35176
## SC(n)      11.86463    11.50477    11.54689    11.58541    11.60755    11.65996
## FPE(n) 125216.91717 80972.28678 78268.19568 75383.73647 71426.10041 69758.25113
##                  7           8           9          10
## AIC(n)    11.15247    11.12878    11.11915    11.12019
## HQ(n)     11.38144    11.38760    11.40784    11.43874
## SC(n)     11.73587    11.78827    11.85473    11.93187
## FPE(n) 69749.89175 68122.40518 67476.96374 67556.45243

Chapter 6 State Space Models

This is the longest chapter in the book! It discusses state space models, which are a very general model that subsume a whole class of special cases of interest. It is analogous to linear regression for non-time series. Note, state space is aka the dynamic linear model, introduced in Kalman (1960) and Kalman and Bucy (1961)–this is the Kalman filter guy.

State Space Models get their name from tracking objects in space. State is the position (from motion equations), space is for spacecraft. So, it was about \(x_t\) is the location of a spacecraft and the data \(y_t\) reflect informatoin that can be observed from a tracking device such as velocity and azimuth. (Azimuth is the direction of a celestial object from the observer, expressed as the angular distance from the north or south point of the horizon to the point at which a vertical circle passing through the object intersects the horizon.) Applying this to economics goes back to Harrison and Stevens (1976), Harvey and Pierse (1984), Harvey and Todd (1983), Kitagawa and Gersch (1984), Shumway and Stoffer (1982). Nonlinear treatment of state space models in Douc Moulines and Stoffer (I have this!).

Focus on linear Gaussian State Space Models. Present various forms of the model, introduce the concepts of prediction, filtering and smoothing state space models and include their derivations. Explain how to do MLE and how to handle missing data. Discuss Hidden Markov Models (HMM), switching autoregressions (this is switching regimes), smoothing splines, ARMAX models, bootstrapping, stochastic volatility and state space models with switching. Finally, discuss Bayesian approach to fitting state space models with MCMC. Core ideas in 6.1-6.3.

Two key principles: (1) a hidden or latent process \(x_t\) called the state process and its a Markov process (so future independent of the past) and (2) the observations \(y_t\) are independent of the state \(x_t\). Thus, the dependence between observations is generated by states.

Note that we did cover these a little bit in my 201C Class.

6.1 Linear Gaussian Models

Example 6.1 A Biomedical Example

plot(blood, type='o', pch=19, xlab='day', main='')

Example 6.2 Global Warming

ts.plot(globtemp, globtempl, col=c(6,4), ylab='Temperature Deviations')

6.2 Filtering, Smoothing and Forecasting

Example 6.5 Prediction Filtering and Smoothing for the Local Level Model

set.seed(1); num = 50
w = rnorm(num+1,0,1); v = rnorm(num,0,1)
mu = cumsum(w) # state: mu[0], mu[1],..., mu[50]
y = mu[-1] + v #
# obs:
# y[1],..., y[50]
# filter and smooth (Ksmooth0 does both)
ks = Ksmooth0(num, y, A=1, mu0=0, Sigma0=1, Phi=1, cQ=1, cR=1)
# start figure
par(mfrow=c(3,1)); Time = 1:num
plot(Time, mu[-1], main='Predict', ylim=c(-5,10))
lines(ks$xp)
lines(ks$xp+2*sqrt(ks$Pp), lty=2, col=4)
lines(ks$xp-2*sqrt(ks$Pp), lty=2, col=4)
plot(Time, mu[-1], main='Filter', ylim=c(-5,10))
lines(ks$xf)
lines(ks$xf+2*sqrt(ks$Pf), lty=2, col=4)
lines(ks$xf-2*sqrt(ks$Pf), lty=2, col=4)
plot(Time, mu[-1], main='Smooth', ylim=c(-5,10))
lines(ks$xs)
lines(ks$xs+2*sqrt(ks$Ps), lty=2, col=4)
lines(ks$xs-2*sqrt(ks$Ps), lty=2, col=4)

mu[1]; ks$x0n; sqrt(ks$P0n)
## [1] -0.6264538
##            [,1]
## [1,] -0.3241541
##           [,1]
## [1,] 0.7861514
 # initial value info

6.3 Maximum Likelihood Estimation

Example 6.6 Newton-Raphson for Example 6.3

# Generate Data
set.seed(999); num = 100
x = arima.sim(n=num+1, list(ar=.8), sd=1)
y = ts(x[-1] + rnorm(num,0,1))
# Initial Estimates
u = ts.intersect(y, lag(y,-1), lag(y,-2))
varu = var(u); coru = cor(u)
phi = coru[1,3]/coru[1,2]
q = (1-phi^2)*varu[1,2]/phi
r = varu[1,1] - q/(1-phi^2)
(init.par = c(phi, sqrt(q), sqrt(r))) # = .91, .51, 1.03
## [1] 0.9087024 0.5107053 1.0291205
# Function to evaluate the likelihood
Linn = function(para){
phi = para[1]; sigw = para[2]; sigv = para[3]
Sigma0 = (sigw^2)/(1-phi^2); Sigma0[Sigma0<0]=0
kf = Kfilter0(num, y, 1, mu0=0, Sigma0, phi, sigw, sigv)
return(kf$like)
 }
# Estimation (partial output shown)
(est = optim(init.par, Linn, gr=NULL, method='BFGS', hessian=TRUE,
control=list(trace=1, REPORT=1)))
## initial  value 81.313627 
## iter   2 value 80.169051
## iter   3 value 79.866131
## iter   4 value 79.222846
## iter   5 value 79.021504
## iter   6 value 79.014723
## iter   7 value 79.014453
## iter   7 value 79.014452
## iter   7 value 79.014452
## final  value 79.014452 
## converged
## $par
## [1] 0.8137623 0.8507863 0.8743968
## 
## $value
## [1] 79.01445
## 
## $counts
## function gradient 
##       23        7 
## 
## $convergence
## [1] 0
## 
## $message
## NULL
## 
## $hessian
##           [,1]     [,2]     [,3]
## [1,] 253.36290 67.39775 -9.64101
## [2,]  67.39775 78.99067 48.61052
## [3,]  -9.64101 48.61052 92.20472
SE = sqrt(diag(solve(est$hessian)))
cbind(estimate=c(phi=est$par[1],sigw=est$par[2],sigv=est$par[3]),SE)
##       estimate         SE
## phi  0.8137623 0.08060636
## sigw 0.8507863 0.17528895
## sigv 0.8743968 0.14293192

Example 6.7 Newton-Raphson for the Global Temperature Deviations

y = cbind(globtemp, globtempl); num = nrow(y); input = rep(1,num)
A = array(rep(1,2), dim=c(2,1,num))
mu0 = -.35; Sigma0 = 1; Phi = 1
# Function to Calculate Likelihood
Linn = function(para){
cQ = para[1]
 # sigma_w
cR1 = para[2]
 # 11 element of chol(R)
cR2 = para[3]
 # 22 element of chol(R)
cR12 = para[4]
 # 12 element of chol(R)
cR = matrix(c(cR1,0,cR12,cR2),2) # put the matrix together
drift = para[5]
kf = Kfilter1(num,y,A,mu0,Sigma0,Phi,drift,0,cQ,cR,input)
return(kf$like)
 }
# Estimation
init.par = c(.1, .1, .1, 0, .05)
(est = optim(init.par, Linn, NULL, method='BFGS', hessian=TRUE,
control=list(trace=1,REPORT=1))) # output not shown
## initial  value -411.324427 
## iter   2 value -426.036689
## iter   3 value -433.552406
## iter   4 value -435.309812
## iter   5 value -435.812931
## iter   6 value -436.293842
## iter   7 value -437.471877
## iter   8 value -440.321476
## iter   9 value -441.702499
## iter  10 value -442.207661
## iter  11 value -442.566939
## iter  12 value -442.773183
## iter  13 value -442.786947
## iter  14 value -442.816191
## iter  15 value -442.847605
## iter  16 value -442.893632
## iter  17 value -442.943235
## iter  18 value -442.971593
## iter  19 value -442.972642
## iter  20 value -442.972877
## iter  20 value -442.972884
## iter  20 value -442.972884
## final  value -442.972884 
## converged
## $par
## [1] 0.05501124 0.07418174 0.12694400 0.12925308 0.00649545
## 
## $value
## [1] -442.9729
## 
## $counts
## function gradient 
##      100       20 
## 
## $convergence
## [1] 0
## 
## $message
## NULL
## 
## $hessian
##            [,1]       [,2]       [,3]       [,4]       [,5]
## [1,] 16049.8803 15522.8553  1531.3139 -3056.1823  -393.5183
## [2,] 15522.8553 33596.2449 -3152.0105 -7422.5391   374.2193
## [3,]  1531.3139 -3152.0105 12537.5987  4427.7293  -409.0193
## [4,] -3056.1823 -7422.5391  4427.7293  3502.8070   347.2511
## [5,]  -393.5183   374.2193  -409.0193   347.2511 44061.8248
SE = sqrt(diag(solve(est$hessian)))
# Display estimates
u = cbind(estimate=est$par, SE)
rownames(u)=c('sigw','cR11', 'cR22', 'cR12', 'drift'); u
##         estimate          SE
## sigw  0.05501124 0.011358852
## cR11  0.07418174 0.009856923
## cR22  0.12694400 0.015481675
## cR12  0.12925308 0.038230357
## drift 0.00649545 0.004787053
# Smooth (first set parameters to their final estimates)
cQ = est$par[1]
cR1 = est$par[2]
cR2 = est$par[3]
cR12 = est$par[4]
cR = matrix(c(cR1,0,cR12,cR2), 2)
(R = t(cR)%*%cR)
##             [,1]        [,2]
## [1,] 0.005502931 0.009588218
## [2,] 0.009588218 0.032821136
 # to view the estimated R matrix
drift = est$par[5]
ks = Ksmooth1(num,y,A,mu0,Sigma0,Phi,drift,0,cQ,cR,input)
# Plot
xsm = ts(as.vector(ks$xs), start=1880)
rmse = ts(sqrt(as.vector(ks$Ps)), start=1880)
plot(xsm, ylim=c(-.6, 1), ylab='Temperature Deviations')
xx = c(time(xsm), rev(time(xsm)))
yy = c(xsm-2*rmse, rev(xsm+2*rmse))
polygon(xx, yy, border=NA, col=gray(.6, alpha=.25))
lines(globtemp, type='o', pch=2, col=4, lty=6)
lines(globtempl, type='o', pch=3, col=3, lty=6)

Example 6.8 EM Algorithm for Example 6.3

library(pacman)
p_load(nlme) # loads package nlme
# Generate data (same as Example 6.6)
set.seed(999); num = 100
x = arima.sim(n=num+1, list(ar = .8), sd=1)
y = ts(x[-1] + rnorm(num,0,1))
# Initial Estimates (same as Example 6.6)
u = ts.intersect(y, lag(y,-1), lag(y,-2))
varu = var(u); coru = cor(u)
phi = coru[1,3]/coru[1,2]
q = (1-phi^2)*varu[1,2]/phi
r = varu[1,1] - q/(1-phi^2)
# EM procedure - output not shown
(em = EM0(num, y, A=1, mu0=0, Sigma0=2.8, Phi=phi, cQ=sqrt(q), cR=sqrt(r),
max.iter=75, tol=.00001))
## iteration    -loglikelihood 
##     1          81.42623 
##     2          80.45488 
##     3          80.12945 
##     4          79.89255 
##     5          79.69011 
##     6          79.50988 
##     7          79.34757 
##     8          79.20113 
##     9          79.06926 
##     10          78.95095 
##     11          78.84526 
##     12          78.75127 
##     13          78.66803 
##     14          78.59461 
##     15          78.53005 
##     16          78.47346 
##     17          78.42394 
##     18          78.38069 
##     19          78.34294 
##     20          78.31001 
##     21          78.28127 
##     22          78.25617 
##     23          78.23422 
##     24          78.21499 
##     25          78.19811 
##     26          78.18324 
##     27          78.17012 
##     28          78.15849 
##     29          78.14816 
##     30          78.13895 
##     31          78.13069 
##     32          78.12328 
##     33          78.11658 
##     34          78.11052 
##     35          78.105 
##     36          78.09996 
##     37          78.09535 
##     38          78.0911 
##     39          78.08718 
##     40          78.08354 
##     41          78.08017 
##     42          78.07702 
##     43          78.07408 
##     44          78.07132 
##     45          78.06873 
##     46          78.06628 
##     47          78.06398 
##     48          78.0618 
##     49          78.05973 
##     50          78.05776 
##     51          78.0559 
##     52          78.05412 
##     53          78.05242 
##     54          78.05079 
##     55          78.04924 
##     56          78.04776 
##     57          78.04633 
##     58          78.04496 
##     59          78.04365 
##     60          78.04239 
##     61          78.04117 
##     62          78.04 
##     63          78.03887 
##     64          78.03779 
##     65          78.03674 
##     66          78.03573 
##     67          78.03475 
##     68          78.0338 
##     69          78.03289 
##     70          78.032 
##     71          78.03115 
##     72          78.03032 
##     73          78.02951 
##     74          78.02873
## $Phi
##           [,1]
## [1,] 0.8097511
## 
## $Q
##           [,1]
## [1,] 0.7280685
## 
## $R
##           [,1]
## [1,] 0.7457129
## 
## $mu0
##           [,1]
## [1,] -1.964872
## 
## $Sigma0
##            [,1]
## [1,] 0.02227538
## 
## $like
##  [1] 81.42623 80.45488 80.12945 79.89255 79.69011 79.50988 79.34757 79.20113
##  [9] 79.06926 78.95095 78.84526 78.75127 78.66803 78.59461 78.53005 78.47346
## [17] 78.42394 78.38069 78.34294 78.31001 78.28127 78.25617 78.23422 78.21499
## [25] 78.19811 78.18324 78.17012 78.15849 78.14816 78.13895 78.13069 78.12328
## [33] 78.11658 78.11052 78.10500 78.09996 78.09535 78.09110 78.08718 78.08354
## [41] 78.08017 78.07702 78.07408 78.07132 78.06873 78.06628 78.06398 78.06180
## [49] 78.05973 78.05776 78.05590 78.05412 78.05242 78.05079 78.04924 78.04776
## [57] 78.04633 78.04496 78.04365 78.04239 78.04117 78.04000 78.03887 78.03779
## [65] 78.03674 78.03573 78.03475 78.03380 78.03289 78.03200 78.03115 78.03032
## [73] 78.02951 78.02873
## 
## $niter
## [1] 74
## 
## $cvg
## [1] 9.989903e-06
# Standard Errors (this uses nlme)
phi = em$Phi; cq = sqrt(em$Q); cr = sqrt(em$R)
mu0 = em$mu0; Sigma0 = em$Sigma0
para = c(phi, cq, cr)
Linn = function(para){ # to evaluate likelihood at estimates
kf = Kfilter0(num, y, 1, mu0, Sigma0, para[1], para[2], para[3])
return(kf$like)
 }
emhess = fdHess(para, function(para) Linn(para)) #from nlme package
SE = sqrt(diag(solve(emhess$Hessian)))
# Display Summary of Estimation
estimate = c(para, em$mu0, em$Sigma0); SE = c(SE, NA, NA)
u = cbind(estimate, SE)
rownames(u) = c('phi','sigw','sigv','mu0','Sigma0'); u
##           estimate         SE
## phi     0.80975110 0.07850146
## sigw    0.85326930 0.16414648
## sigv    0.86354667 0.13659399
## mu0    -1.96487182         NA
## Sigma0  0.02227538         NA

6.4 Missing Data Modification

Example 6.9 Longitudinal Biomedical Data

y = cbind(WBC, PLT, HCT); num = nrow(y)
# make array of obs matrices
A = array(0, dim=c(3,3,num))
for(k in 1:num) { if (y[k,1] > 0) A[,,k]= diag(1,3) }
# Initial values
mu0 = matrix(0, 3, 1); Sigma0 = diag(c(.1, .1, 1), 3)
Phi = diag(1, 3); cQ = diag(c(.1, .1, 1), 3); cR = diag(c(.1, .1, 1), 3)
# EM procedure - some output previously shown
(em = EM1(num, y, A, mu0, Sigma0, Phi, cQ, cR, 100, .001))
## iteration    -loglikelihood 
##     1          68.28328 
##     2          -183.9361 
##     3          -194.2051 
##     4          -197.5444 
##     5          -199.7442 
##     6          -201.6431 
##     7          -203.4226 
##     8          -205.1253 
##     9          -206.7595 
##     10          -208.3251 
##     11          -209.8209 
##     12          -211.2464 
##     13          -212.602 
##     14          -213.8891 
##     15          -215.1094 
##     16          -216.2651 
##     17          -217.3589 
##     18          -218.3931 
##     19          -219.3705 
##     20          -220.2935 
##     21          -221.1649 
##     22          -221.9869 
##     23          -222.762 
##     24          -223.4924 
##     25          -224.1805 
##     26          -224.8282 
##     27          -225.4377 
##     28          -226.0109 
##     29          -226.5495 
##     30          -227.0555 
##     31          -227.5305 
##     32          -227.9762 
##     33          -228.3941 
##     34          -228.7857 
##     35          -229.1524 
##     36          -229.4956 
##     37          -229.8166 
##     38          -230.1166 
##     39          -230.3967 
##     40          -230.6582 
##     41          -230.9019 
##     42          -231.1289
## $Phi
##             [,1]        [,2]        [,3]
## [1,]  0.98052698 -0.03494377 0.008287009
## [2,]  0.05279121  0.93299479 0.005464917
## [3,] -1.46571679  2.25780951 0.795200344
## 
## $Q
##              [,1]         [,2]       [,3]
## [1,]  0.013786772 -0.001724166 0.01882951
## [2,] -0.001724166  0.003032109 0.03528162
## [3,]  0.018829510  0.035281625 3.61897901
## 
## $R
##             [,1]      [,2]      [,3]
## [1,] 0.007124671 0.0000000 0.0000000
## [2,] 0.000000000 0.0168669 0.0000000
## [3,] 0.000000000 0.0000000 0.9724247
## 
## $mu0
##           [,1]
## [1,]  2.119269
## [2,]  4.407390
## [3,] 23.905038
## 
## $Sigma0
##               [,1]          [,2]          [,3]
## [1,]  4.553949e-04 -5.249215e-05  0.0005877626
## [2,] -5.249215e-05  3.136928e-04 -0.0001199788
## [3,]  5.877626e-04 -1.199788e-04  0.1677365489
## 
## $like
##  [1]   68.28328 -183.93608 -194.20509 -197.54440 -199.74425 -201.64313
##  [7] -203.42258 -205.12530 -206.75951 -208.32511 -209.82091 -211.24639
## [13] -212.60202 -213.88906 -215.10935 -216.26514 -217.35887 -218.39311
## [19] -219.37048 -220.29354 -221.16485 -221.98686 -222.76196 -223.49243
## [25] -224.18049 -224.82824 -225.43771 -226.01085 -226.54953 -227.05552
## [31] -227.53054 -227.97621 -228.39410 -228.78569 -229.15242 -229.49563
## [37] -229.81661 -230.11659 -230.39674 -230.65816 -230.90189 -231.12893
## 
## $niter
## [1] 42
## 
## $cvg
## [1] 0.0009832656
# Graph smoother
ks = Ksmooth1(num, y, A, em$mu0, em$Sigma0, em$Phi, 0, 0, chol(em$Q),
chol(em$R), 0)
y1s = ks$xs[1,,]; y2s = ks$xs[2,,]; y3s = ks$xs[3,,]
p1 = 2*sqrt(ks$Ps[1,1,]); p2 = 2*sqrt(ks$Ps[2,2,]); p3 = 2*sqrt(ks$Ps[3,3,])
par(mfrow=c(3,1))
plot(WBC, type='p', pch=19, ylim=c(1,5), xlab='day')
lines(y1s); lines(y1s+p1, lty=2, col=4); lines(y1s-p1, lty=2, col=4)
plot(PLT, type='p', ylim=c(3,6), pch=19, xlab='day')
lines(y2s); lines(y2s+p2, lty=2, col=4); lines(y2s-p2, lty=2, col=4)
plot(HCT, type='p', pch=19, ylim=c(20,40), xlab='day')
lines(y3s); lines(y3s+p3, lty=2, col=4); lines(y3s-p3, lty=2, col=4)

6.5 Structural Models: Signal Extraction and Forecasting

Example 6.10 Johnson and Johnson Quarterly Earnings

num = length(jj)
A = cbind(1,1,0,0)
# Function to Calculate Likelihood
Linn =function(para){
Phi = diag(0,4); Phi[1,1] = para[1]
Phi[2,]=c(0,-1,-1,-1); Phi[3,]=c(0,1,0,0); Phi[4,]=c(0,0,1,0)
cQ1 = para[2]; cQ2 = para[3]
 # sqrt q11 and q22
cQ = diag(0,4); cQ[1,1]=cQ1; cQ[2,2]=cQ2
cR = para[4]
 # sqrt r11
kf = Kfilter0(num, jj, A, mu0, Sigma0, Phi, cQ, cR)
return(kf$like) }
# Initial Parameters
mu0 = c(.7,0,0,0); Sigma0 = diag(.04,4)
init.par = c(1.03,.1,.1,.5)
 # Phi[1,1], the 2 cQs and cR
# Estimation and Results
est = optim(init.par, Linn,NULL, method='BFGS', hessian=TRUE,
control=list(trace=1,REPORT=1))
## initial  value 2.693644 
## iter   2 value -0.853526
## iter   3 value -9.416505
## iter   4 value -10.241752
## iter   5 value -19.419809
## iter   6 value -30.441188
## iter   7 value -31.825543
## iter   8 value -32.248413
## iter   9 value -32.839918
## iter  10 value -33.019870
## iter  11 value -33.041749
## iter  12 value -33.050583
## iter  13 value -33.055492
## iter  14 value -33.078152
## iter  15 value -33.096870
## iter  16 value -33.098405
## iter  17 value -33.099018
## iter  18 value -33.099385
## iter  19 value -33.099498
## iter  19 value -33.099498
## final  value -33.099498 
## converged
SE = sqrt(diag(solve(est$hessian)))
u = cbind(estimate=est$par, SE)
rownames(u)=c('Phi11','sigw1','sigw2','sigv'); u
##           estimate         SE
## Phi11 1.0350847657 0.00253645
## sigw1 0.1397255477 0.02155155
## sigw2 0.2208782663 0.02376430
## sigv  0.0004655672 0.24174702
# Smooth
Phi = diag(0,4); Phi[1,1] = est$par[1]
Phi[2,]=c(0,-1,-1,-1); Phi[3,]=c(0,1,0,0); Phi[4,]=c(0,0,1,0)
cQ1 = est$par[2]; cQ2 = est$par[3]
cQ = diag(1,4); cQ[1,1]=cQ1; cQ[2,2]=cQ2
cR = est$par[4]
ks = Ksmooth0(num,jj,A,mu0,Sigma0,Phi,cQ,cR)
# Plots
Tsm = ts(ks$xs[1,,], start=1960, freq=4)
Ssm = ts(ks$xs[2,,], start=1960, freq=4)
p1 = 3*sqrt(ks$Ps[1,1,]); p2 = 3*sqrt(ks$Ps[2,2,])
par(mfrow=c(2,1))
plot(Tsm, main='Trend Component', ylab='Trend')
xx = c(time(jj), rev(time(jj)))
yy = c(Tsm-p1, rev(Tsm+p1))
polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))
plot(jj, main='Data & Trend+Season', ylab='J&J QE/Share', ylim=c(-.5,17))
xx = c(time(jj), rev(time(jj)) )
yy = c((Tsm+Ssm)-(p1+p2), rev((Tsm+Ssm)+(p1+p2)) )
polygon(xx, yy, border=NA, col=gray(.5, alpha = .3))

# Forecast
n.ahead = 12;
y = ts(append(jj, rep(0,n.ahead)), start=1960, freq=4)
rmspe = rep(0,n.ahead); x00 = ks$xf[,,num]; P00 = ks$Pf[,,num]
Q = t(cQ)%*%cQ; R = t(cR)%*%(cR)
for (m in 1:n.ahead){
xp = Phi%*%x00; Pp = Phi%*%P00%*%t(Phi)+Q
sig = A%*%Pp%*%t(A)+R; K = Pp%*%t(A)%*%(1/sig)
x00 = xp; P00 = Pp-K%*%A%*%Pp
y[num+m] = A%*%xp; rmspe[m] = sqrt(sig) }
plot(y, type='o', main='', ylab='J&J QE/Share', ylim=c(5,30),
xlim=c(1975,1984))
upp = ts(y[(num+1):(num+n.ahead)]+2*rmspe, start=1981, freq=4)
low = ts(y[(num+1):(num+n.ahead)]-2*rmspe, start=1981, freq=4)
xx = c(time(low), rev(time(upp)))
yy = c(low, rev(upp))
polygon(xx, yy, border=8, col=gray(.5, alpha = .3))
abline(v=1981, lty=3)

6.6 State-Space Models with Correlated Errors

Example 6.12 Mortality, Temperature and Pollution for ARMAX model

fit1 = sarima(cmort, 2,0,0, xreg=time(cmort))
## initial  value 2.184467 
## iter   2 value 2.010634
## iter   3 value 1.747767
## iter   4 value 1.736198
## iter   5 value 1.732020
## iter   6 value 1.732018
## iter   7 value 1.732015
## iter   8 value 1.732009
## iter   9 value 1.731998
## iter  10 value 1.731983
## iter  11 value 1.731978
## iter  12 value 1.731975
## iter  13 value 1.731975
## iter  14 value 1.731975
## iter  15 value 1.731974
## iter  16 value 1.731974
## iter  17 value 1.731973
## iter  18 value 1.731972
## iter  19 value 1.731972
## iter  19 value 1.731972
## final  value 1.731972 
## converged
## initial  value 1.732498 
## iter   2 value 1.732496
## iter   3 value 1.732484
## iter   4 value 1.732480
## iter   5 value 1.732471
## iter   6 value 1.732463
## iter   7 value 1.732451
## iter   8 value 1.732446
## iter   9 value 1.732445
## iter  10 value 1.732445
## iter  10 value 1.732445
## final  value 1.732445 
## converged

acf(cbind(dmort <- resid(fit1$fit), tempr, part))

lag2.plot(tempr, dmort, 8)

lag2.plot(part, dmort, 8)

trend = time(cmort) - mean(time(cmort))
 # center time
dcmort = resid(fit2 <- lm(cmort~trend, na.action=NULL)); fit2
## 
## Call:
## lm(formula = cmort ~ trend, na.action = NULL)
## 
## Coefficients:
## (Intercept)        trend  
##      88.699       -1.625
u = ts.intersect(dM=dcmort, dM1=lag(dcmort,-1), dM2=lag(dcmort,-2),
T1=lag(tempr,-1), P=part, P4=lag(part,-4))
# lm(dM~., data=u, na.action=NULL)
 # and then anaylze residuals ... or
sarima(u[,1], 0,0,0, xreg=u[,2:6])
## initial  value 1.617677 
## iter   1 value 1.617677
## final  value 1.617677 
## converged
## initial  value 1.617677 
## iter   1 value 1.617677
## final  value 1.617677 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##       intercept     dM1     dM2       T1       P      P4
##          5.9884  0.3164  0.2989  -0.1826  0.1107  0.0495
## s.e.     2.6401  0.0370  0.0395   0.0309  0.0177  0.0195
## 
## sigma^2 estimated as 25.42:  log likelihood = -1530.45,  aic = 3074.91
## 
## $degrees_of_freedom
## [1] 498
## 
## $ttable
##           Estimate     SE t.value p.value
## intercept   5.9884 2.6401  2.2683  0.0237
## dM1         0.3164 0.0370  8.5442  0.0000
## dM2         0.2989 0.0395  7.5749  0.0000
## T1         -0.1826 0.0309 -5.9090  0.0000
## P           0.1107 0.0177  6.2378  0.0000
## P4          0.0495 0.0195  2.5463  0.0112
## 
## $AIC
## [1] 6.101008
## 
## $AICc
## [1] 6.101343
## 
## $BIC
## [1] 6.159655
 # get residual analysis as a byproduct


# for complete analysis
trend = time(cmort) - mean(time(cmort))
 # center time
const = time(cmort)/time(cmort)
 # appropriate time series of 1s
ded = ts.intersect(M=cmort, T1=lag(tempr,-1), P=part, P4=lag(part,-4),
trend, const)
y = ded[,1]
input = ded[,2:6]
num = length(y)
A = array(c(1,0), dim = c(1,2,num))
# Function to Calculate Likelihood
Linn=function(para){
phi1=para[1]; phi2=para[2]; cR=para[3];
 b1=para[4]
b2=para[5];
 b3=para[6]; b4=para[7]; alf=para[8]
mu0 = matrix(c(0,0), 2, 1)
Sigma0 = diag(100, 2)
Phi = matrix(c(phi1, phi2, 1, 0), 2)
Theta = matrix(c(phi1, phi2), 2)
Ups = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
Gam = matrix(c(0, 0, 0, b4, alf), 1, 5); cQ = cR; S = cR^2
kf = Kfilter2(num, y, A, mu0, Sigma0, Phi, Ups, Gam, Theta, cQ, cR, S, input)
return(kf$like) }
# Estimation
init.par = c(phi1=.3, phi2=.3, cR=5, b1=-.2, b2=.1, b3=.05, b4=-1.6,
alf=mean(cmort))
 # initial parameters
L = c( 0, 0, 1, -1, 0, 0, -2, 70)
 # lower bound on parameters
U = c(.5, .5, 10, 0, .5, .5, 0, 90)
 # upper bound - used in optim
est = optim(init.par, Linn, NULL, method='L-BFGS-B', lower=L, upper=U,
hessian=TRUE, control=list(trace=1, REPORT=1, factr=10^8))
## iter    1 value 1200.869610
## iter    2 value 1104.052748
## iter    3 value 1089.671838
## iter    4 value 1087.457197
## iter    5 value 1078.395717
## iter    6 value 1073.096514
## iter    7 value 1071.365536
## iter    8 value 1071.314737
## iter    9 value 1071.179742
## iter   10 value 1070.837070
## iter   11 value 1070.373288
## iter   12 value 1070.307398
## iter   13 value 1070.305185
## iter   14 value 1070.300366
## iter   15 value 1070.295978
## iter   16 value 1070.283255
## iter   17 value 1070.265615
## iter   18 value 1070.258011
## iter   19 value 1070.256290
## iter   20 value 1070.252565
## iter   21 value 1070.247091
## iter   22 value 1070.240279
## iter   23 value 1070.229766
## iter   24 value 1070.216921
## iter   25 value 1070.209799
## iter   26 value 1070.191058
## iter   27 value 1070.180176
## iter   28 value 1070.154140
## iter   29 value 1070.104227
## iter   30 value 1069.961996
## iter   31 value 1069.868449
## iter   32 value 1069.860435
## iter   33 value 1069.794190
## iter   34 value 1069.776327
## iter   35 value 1069.772424
## iter   36 value 1069.766588
## iter   37 value 1069.757520
## iter   38 value 1069.751688
## iter   39 value 1069.746828
## iter   40 value 1069.745785
## iter   41 value 1069.745557
## iter   42 value 1069.744533
## iter   43 value 1069.744311
## iter   44 value 1069.743254
## iter   45 value 1069.743174
## iter   46 value 1069.743008
## iter   47 value 1069.742981
## iter   48 value 1069.742961
## final  value 1069.742961 
## converged
SE = sqrt(diag(solve(est$hessian)))
round(cbind(estimate=est$par, SE), 3)
##      estimate    SE
## phi1    0.315 0.037
## phi2    0.318 0.041
## cR      5.061 0.161
## b1     -0.119 0.031
## b2      0.119 0.018
## b3      0.067 0.019
## b4     -1.340 0.220
## alf    88.752 7.015
# results


# Residual Analysis (not shown)
phi1 = est$par[1]; phi2 = est$par[2]
cR = est$par[3];
 b1 = est$par[4]
b2 = est$par[5];
 b3 = est$par[6]
b4 = est$par[7]; alf = est$par[8]
mu0 = matrix(c(0,0), 2, 1); Sigma0 = diag(100, 2)
Phi = matrix(c(phi1, phi2, 1, 0), 2)
Theta = matrix(c(phi1, phi2), 2)
Ups = matrix(c(b1, 0, b2, 0, b3, 0, 0, 0, 0, 0), 2, 5)
Gam = matrix(c(0, 0, 0, b4, alf), 1, 5)
cQ = cR
S = cR^2
kf= Kfilter2(num, y, A, mu0, Sigma0, Phi, Ups, Gam, Theta, cQ, cR, S,
input)
res = ts(as.vector(kf$innov), start=start(cmort), freq=frequency(cmort))

sarima(res, 0,0,0, no.constant=TRUE)

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xmean, include.mean = FALSE, transform.pars = trans, 
##     fixed = fixed, optim.control = list(trace = trc, REPORT = 1, reltol = tol))
## 
## 
## sigma^2 estimated as 25.58:  log likelihood = -1532.05,  aic = 3066.11
## 
## $degrees_of_freedom
## [1] 504
## 
## $ttable
##      Estimate p.value
## 
## $AIC
## [1] 6.083551
## 
## $AICc
## [1] 6.083551
## 
## $BIC
## [1] 6.091929
#alternative 
trend = time(cmort) - mean(time(cmort))
u = ts.intersect(M=cmort, M1=lag(cmort,-1), M2=lag(cmort,-2),
T1=lag(tempr,-1), P=part, P4=lag(part,-4), trend)
sarima(u[,1], 0,0,0, xreg=u[,2:7])
## initial  value 1.615874 
## iter   1 value 1.615874
## final  value 1.615874 
## converged
## initial  value 1.615874 
## iter   1 value 1.615874
## final  value 1.615874 
## converged

## $fit
## 
## Call:
## stats::arima(x = xdata, order = c(p, d, q), seasonal = list(order = c(P, D, 
##     Q), period = S), xreg = xreg, transform.pars = trans, fixed = fixed, optim.control = list(trace = trc, 
##     REPORT = 1, reltol = tol))
## 
## Coefficients:
##       intercept     M1      M2       T1       P      P4    trend
##         40.3838  0.315  0.2971  -0.1845  0.1113  0.0513  -0.5214
## s.e.     4.5982  0.037  0.0394   0.0309  0.0177  0.0195   0.0956
## 
## sigma^2 estimated as 25.32:  log likelihood = -1529.55,  aic = 3075.09
## 
## $degrees_of_freedom
## [1] 497
## 
## $ttable
##           Estimate     SE t.value p.value
## intercept  40.3838 4.5982  8.7825  0.0000
## M1          0.3150 0.0370  8.5185  0.0000
## M2          0.2971 0.0394  7.5403  0.0000
## T1         -0.1845 0.0309 -5.9750  0.0000
## P           0.1113 0.0177  6.2827  0.0000
## P4          0.0513 0.0195  2.6380  0.0086
## trend      -0.5214 0.0956 -5.4533  0.0000
## 
## $AIC
## [1] 6.101371
## 
## $AICc
## [1] 6.10182
## 
## $BIC
## [1] 6.168397
 # could use lm, but it's more work

6.7 Bootstrapping State Space Models

Example …

library(plyr) # used for displaying progress
tol = sqrt(.Machine$double.eps) #determines convergence of optimizer
nboot = 500
 # number of bootstrap replicates
y = window(qinfl, c(1953,1), c(1965,2)) # inflation
z = window(qintr, c(1953,1), c(1965,2)) # interest
num = length(y)
A = array(z, dim=c(1,1,num))
input = matrix(1,num,1)
# Function to Calculate Likelihood
Linn = function(para, y.data){ # pass data also
phi = para[1]; alpha = para[2]
b = para[3]; Ups = (1-phi)*b
cQ = para[4]; cR = para[5]
kf = Kfilter2(num,y.data,A,mu0,Sigma0,phi,Ups,alpha,1,cQ,cR,0,input)
return(kf$like)
 }
# Parameter Estimation
mu0 = 1; Sigma0 = .01
init.par = c(phi=.84, alpha=-.77, b=.85, cQ=.12, cR=1.1) # initial values
est = optim(init.par, Linn, NULL, y.data=y, method="BFGS", hessian=TRUE,
control=list(trace=1, REPORT=1, reltol=tol))
## initial  value 35.774060 
## iter   2 value 35.742590
## iter   3 value 35.720343
## iter   4 value 35.705235
## iter   5 value 35.699251
## iter   6 value 35.692505
## iter   7 value 35.684180
## iter   8 value 35.684117
## iter   9 value 35.684115
## iter   9 value 35.684115
## iter   9 value 35.684115
## final  value 35.684115 
## converged
SE = sqrt(diag(solve(est$hessian)))
phi = est$par[1]; alpha = est$par[2]
b = est$par[3]; Ups = (1-phi)*b
cQ = est$par[4]; cR = est$par[5]
round(cbind(estimate=est$par, SE), 3)
##       estimate    SE
## phi      0.865 0.223
## alpha   -0.686 0.487
## b        0.788 0.226
## cQ       0.115 0.107
## cR       1.135 0.147
# BEGIN BOOTSTRAP
# Run the filter at the estimates
kf = Kfilter2(num,y,A,mu0,Sigma0,phi,Ups,alpha,1,cQ,cR,0,input)
# Pull out necessary values from the filter and initialize
xp = kf$xp
innov = kf$innov
sig = kf$sig
K = kf$K
e = innov/sqrt(sig)
e.star = e
 # initialize values
y.star = y
xp.star = xp
k = 4:50
 # hold first 3 observations fixed
para.star = matrix(0, nboot, 5) # to store estimates
init.par = c(.84, -.77, .85, .12, 1.1)
pr <- progress_text()
 # displays progress
pr$init(nboot)
## 
  |                                                                            
  |                                                                      |   0%
for (i in 1:nboot){
pr$step()
e.star[k] = sample(e[k], replace=TRUE)
for (j in k){ xp.star[j] = phi*xp.star[j-1] +
Ups+K[j]*sqrt(sig[j])*e.star[j] }
y.star[k] = z[k]*xp.star[k] + alpha + sqrt(sig[k])*e.star[k]
est.star = optim(init.par, Linn, NULL, y.data=y.star, method="BFGS",
control=list(reltol=tol))
para.star[i,] = cbind(est.star$par[1], est.star$par[2], est.star$par[3],
abs(est.star$par[4]), abs(est.star$par[5]))
 }
## 
  |                                                                            
  |                                                                      |   1%
  |                                                                            
  |=                                                                     |   1%
  |                                                                            
  |=                                                                     |   2%
  |                                                                            
  |==                                                                    |   2%
  |                                                                            
  |==                                                                    |   3%
  |                                                                            
  |===                                                                   |   4%
  |                                                                            
  |===                                                                   |   5%
  |                                                                            
  |====                                                                  |   5%
  |                                                                            
  |====                                                                  |   6%
  |                                                                            
  |=====                                                                 |   7%
  |                                                                            
  |=====                                                                 |   8%
  |                                                                            
  |======                                                                |   8%
  |                                                                            
  |======                                                                |   9%
  |                                                                            
  |=======                                                               |   9%
  |                                                                            
  |=======                                                               |  10%
  |                                                                            
  |=======                                                               |  11%
  |                                                                            
  |========                                                              |  11%
  |                                                                            
  |========                                                              |  12%
  |                                                                            
  |=========                                                             |  12%
  |                                                                            
  |=========                                                             |  13%
  |                                                                            
  |==========                                                            |  14%
  |                                                                            
  |==========                                                            |  15%
  |                                                                            
  |===========                                                           |  15%
  |                                                                            
  |===========                                                           |  16%
  |                                                                            
  |============                                                          |  17%
  |                                                                            
  |============                                                          |  18%
  |                                                                            
  |=============                                                         |  18%
  |                                                                            
  |=============                                                         |  19%
  |                                                                            
  |==============                                                        |  19%
  |                                                                            
  |==============                                                        |  20%
  |                                                                            
  |==============                                                        |  21%
  |                                                                            
  |===============                                                       |  21%
  |                                                                            
  |===============                                                       |  22%
  |                                                                            
  |================                                                      |  22%
  |                                                                            
  |================                                                      |  23%
  |                                                                            
  |=================                                                     |  24%
  |                                                                            
  |=================                                                     |  25%
  |                                                                            
  |==================                                                    |  25%
  |                                                                            
  |==================                                                    |  26%
  |                                                                            
  |===================                                                   |  27%
  |                                                                            
  |===================                                                   |  28%
  |                                                                            
  |====================                                                  |  28%
  |                                                                            
  |====================                                                  |  29%
  |                                                                            
  |=====================                                                 |  29%
  |                                                                            
  |=====================                                                 |  30%
  |                                                                            
  |=====================                                                 |  31%
  |                                                                            
  |======================                                                |  31%
  |                                                                            
  |======================                                                |  32%
  |                                                                            
  |=======================                                               |  32%
  |                                                                            
  |=======================                                               |  33%
  |                                                                            
  |========================                                              |  34%
  |                                                                            
  |========================                                              |  35%
  |                                                                            
  |=========================                                             |  35%
  |                                                                            
  |=========================                                             |  36%
  |                                                                            
  |==========================                                            |  37%
  |                                                                            
  |==========================                                            |  38%
  |                                                                            
  |===========================                                           |  38%
  |                                                                            
  |===========================                                           |  39%
  |                                                                            
  |============================                                          |  39%
  |                                                                            
  |============================                                          |  40%
  |                                                                            
  |============================                                          |  41%
  |                                                                            
  |=============================                                         |  41%
  |                                                                            
  |=============================                                         |  42%
  |                                                                            
  |==============================                                        |  42%
  |                                                                            
  |==============================                                        |  43%
  |                                                                            
  |===============================                                       |  44%
  |                                                                            
  |===============================                                       |  45%
  |                                                                            
  |================================                                      |  45%
  |                                                                            
  |================================                                      |  46%
  |                                                                            
  |=================================                                     |  47%
  |                                                                            
  |=================================                                     |  48%
  |                                                                            
  |==================================                                    |  48%
  |                                                                            
  |==================================                                    |  49%
  |                                                                            
  |===================================                                   |  49%
  |                                                                            
  |===================================                                   |  50%
  |                                                                            
  |===================================                                   |  51%
  |                                                                            
  |====================================                                  |  51%
  |                                                                            
  |====================================                                  |  52%
  |                                                                            
  |=====================================                                 |  52%
  |                                                                            
  |=====================================                                 |  53%
  |                                                                            
  |======================================                                |  54%
  |                                                                            
  |======================================                                |  55%
  |                                                                            
  |=======================================                               |  55%
  |                                                                            
  |=======================================                               |  56%
  |                                                                            
  |========================================                              |  57%
  |                                                                            
  |========================================                              |  58%
  |                                                                            
  |=========================================                             |  58%
  |                                                                            
  |=========================================                             |  59%
  |                                                                            
  |==========================================                            |  59%
  |                                                                            
  |==========================================                            |  60%
  |                                                                            
  |==========================================                            |  61%
  |                                                                            
  |===========================================                           |  61%
  |                                                                            
  |===========================================                           |  62%
  |                                                                            
  |============================================                          |  62%
  |                                                                            
  |============================================                          |  63%
  |                                                                            
  |=============================================                         |  64%
  |                                                                            
  |=============================================                         |  65%
  |                                                                            
  |==============================================                        |  65%
  |                                                                            
  |==============================================                        |  66%
  |                                                                            
  |===============================================                       |  67%
  |                                                                            
  |===============================================                       |  68%
  |                                                                            
  |================================================                      |  68%
  |                                                                            
  |================================================                      |  69%
  |                                                                            
  |=================================================                     |  69%
  |                                                                            
  |=================================================                     |  70%
  |                                                                            
  |=================================================                     |  71%
  |                                                                            
  |==================================================                    |  71%
  |                                                                            
  |==================================================                    |  72%
  |                                                                            
  |===================================================                   |  72%
  |                                                                            
  |===================================================                   |  73%
  |                                                                            
  |====================================================                  |  74%
  |                                                                            
  |====================================================                  |  75%
  |                                                                            
  |=====================================================                 |  75%
  |                                                                            
  |=====================================================                 |  76%
  |                                                                            
  |======================================================                |  77%
  |                                                                            
  |======================================================                |  78%
  |                                                                            
  |=======================================================               |  78%
  |                                                                            
  |=======================================================               |  79%
  |                                                                            
  |========================================================              |  79%
  |                                                                            
  |========================================================              |  80%
  |                                                                            
  |========================================================              |  81%
  |                                                                            
  |=========================================================             |  81%
  |                                                                            
  |=========================================================             |  82%
  |                                                                            
  |==========================================================            |  82%
  |                                                                            
  |==========================================================            |  83%
  |                                                                            
  |===========================================================           |  84%
  |                                                                            
  |===========================================================           |  85%
  |                                                                            
  |============================================================          |  85%
  |                                                                            
  |============================================================          |  86%
  |                                                                            
  |=============================================================         |  87%
  |                                                                            
  |=============================================================         |  88%
  |                                                                            
  |==============================================================        |  88%
  |                                                                            
  |==============================================================        |  89%
  |                                                                            
  |===============================================================       |  89%
  |                                                                            
  |===============================================================       |  90%
  |                                                                            
  |===============================================================       |  91%
  |                                                                            
  |================================================================      |  91%
  |                                                                            
  |================================================================      |  92%
  |                                                                            
  |=================================================================     |  92%
  |                                                                            
  |=================================================================     |  93%
  |                                                                            
  |==================================================================    |  94%
  |                                                                            
  |==================================================================    |  95%
  |                                                                            
  |===================================================================   |  95%
  |                                                                            
  |===================================================================   |  96%
  |                                                                            
  |====================================================================  |  97%
  |                                                                            
  |====================================================================  |  98%
  |                                                                            
  |===================================================================== |  98%
  |                                                                            
  |===================================================================== |  99%
  |                                                                            
  |======================================================================|  99%
  |                                                                            
  |======================================================================| 100%
# Some summary statistics
rmse = rep(NA,5)
 # SEs from the bootstrap
for(i in 1:5){rmse[i]=sqrt(sum((para.star[,i]-est$par[i])^2)/nboot)
cat(i, rmse[i],"\n") }
## 1 0.4759727 
## 2 0.5445788 
## 3 1.040695 
## 4 0.1961747 
## 5 0.3284463
# Plot phi and sigw
phi = para.star[,1]
sigw = abs(para.star[,4])
phi = ifelse(phi<0, NA, phi)
 # any phi < 0 not plotted
library(psych)
## 
## Attaching package: 'psych'
## The following object is masked from 'package:fBasics':
## 
##     tr
## The following object is masked from 'package:timeSeries':
## 
##     outlier
 # load psych package for scatter.hist
scatter.hist(sigw, phi, ylab=expression(phi), xlab=expression(sigma[~w]),
smooth=FALSE, correl=FALSE, density=FALSE, ellipse=FALSE,
title='', pch=19, col=gray(.1,alpha=.33),
panel.first=grid(lty=2), cex.lab=1.2)

6.8 Smoothing Splines and the Kalman Smoother

Example 6.14 Smoothing Splines

set.seed(123)
num = 50
w = rnorm(num,0,.1)
x = cumsum(cumsum(w))
y = x + rnorm(num,0,1)
plot.ts(x, ylab="", lwd=2, ylim=c(-1,8))
lines(y, type='o', col=8)
## State Space ##
Phi = matrix(c(2,1,-1,0),2); A = matrix(c(1,0),1)
mu0 = matrix(0,2);
 Sigma0 = diag(1,2)
Linn = function(para){
sigw = para[1]; sigv = para[2]
cQ = diag(c(sigw,0))
kf = Kfilter0(num, y, A, mu0, Sigma0, Phi, cQ, sigv)
return(kf$like)
 }
## Estimation ##
init.par = c(.1, 1)
(est = optim(init.par, Linn, NULL, method="BFGS", hessian=TRUE,
control=list(trace=1,REPORT=1)))
## initial  value 33.776567 
## iter   2 value 33.597623
## iter   3 value 33.521581
## iter   4 value 33.480460
## iter   5 value 33.476128
## iter   6 value 33.476047
## iter   7 value 33.476046
## iter   7 value 33.476046
## iter   7 value 33.476046
## final  value 33.476046 
## converged
## $par
## [1] 0.0816401 0.9385482
## 
## $value
## [1] 33.47605
## 
## $counts
## function gradient 
##       27        7 
## 
## $convergence
## [1] 0
## 
## $message
## NULL
## 
## $hessian
##           [,1]     [,2]
## [1,] 557.49454 69.45007
## [2,]  69.45007 94.43305
SE = sqrt(diag(solve(est$hessian)))
# Summary of estimation
estimate = est$par; u = cbind(estimate, SE)
rownames(u) = c("sigw","sigv"); u
##       estimate         SE
## sigw 0.0816401 0.04443707
## sigv 0.9385482 0.10797015
# Smooth
sigw = est$par[1]
cQ = diag(c(sigw,0))
sigv = est$par[2]
ks = Ksmooth0(num, y, A, mu0, Sigma0, Phi, cQ, sigv)
xsmoo = ts(ks$xs[1,1,]); psmoo = ts(ks$Ps[1,1,])
upp = xsmoo+2*sqrt(psmoo); low = xsmoo-2*sqrt(psmoo)
lines(xsmoo, col=4, lty=2, lwd=3)
lines(upp, col=4, lty=2); lines(low, col=4, lty=2)
lines(smooth.spline(y), lty=1, col=2)
legend("topleft", c("Observations","State"), pch=c(1,-1), lty=1, lwd=c(1,2),
col=c(8,1))
legend("bottomright", c("Smoother", "GCV Spline"), lty=c(2,1), lwd=c(3,1), col = c(4,2))

## 6.9 Hidden Markov Models and Switching Autoregression

Example 6.16 Poisson HMM - Number of Major Earthquakes

library(depmixS4)
## Loading required package: nnet
## Loading required package: Rsolnp
model <- depmix(EQcount ~1, nstates=2, data=data.frame(EQcount),
family=poisson())
set.seed(90210)
summary(fm <- fit(model))
## converged at iteration 26 with logLik: -341.8787 
## Initial state probabilities model 
## pr1 pr2 
##   1   0 
## 
## Transition matrix 
##         toS1  toS2
## fromS1 0.928 0.072
## fromS2 0.119 0.881
## 
## Response parameters 
## Resp 1 : poisson 
##     Re1.(Intercept)
## St1           2.736
## St2           3.259
 # estimation results
##-- Get Parameters --##
u = as.vector(getpars(fm)) # ensure state 1 has smaller lambda
if (u[7] <= u[8]) { para.mle = c(u[3:6], exp(u[7]), exp(u[8]))
} else { para.mle = c(u[6:3], exp(u[8]), exp(u[7])) }
mtrans = matrix(para.mle[1:4], byrow=TRUE, nrow=2)
lams = para.mle[5:6]
pi1 = mtrans[2,1]/(2 - mtrans[1,1] - mtrans[2,2]); pi2 = 1-pi1
##-- Graphics --##
layout(matrix(c(1,2,1,3), 2))
par(mar = c(3,3,1,1), mgp = c(1.6,.6,0))
# data and states
plot(EQcount, main="", ylab='EQcount', type='h', col=gray(.7))
text(EQcount, col=6*posterior(fm)[,1]-2, labels=posterior(fm)[,1], cex=.9)
# prob of state 2
plot(ts(posterior(fm)[,3], start=1900), ylab =
expression(hat(pi)[~2]*'(t|n)')); abline(h=.5, lty=2)
# histogram
hist(EQcount, breaks=30, prob=TRUE, main="")
xvals = seq(1,45)
u1 = pi1*dpois(xvals, lams[1])
u2 = pi2*dpois(xvals, lams[2])
lines(xvals, u1, col=4);
 lines(xvals, u2, col=2)

##-- Bootstap --##
# function to generate data
pois.HMM.generate_sample = function(n,m,lambda,Mtrans,StatDist=NULL){
# n = data length, m = number of states, Mtrans = transition matrix,
# StatDist = stationary distn
if(is.null(StatDist)) StatDist = solve(t(diag(m)-Mtrans +1),rep(1,m))
mvect = 1:m
state = numeric(n)
state[1] = sample(mvect ,1, prob=StatDist)
for (i in 2:n)
state[i] = sample(mvect ,1,prob=Mtrans[state[i-1] ,])
y = rpois(n,lambda=lambda[state ])
list(y= y, state= state)
 }
# start it up
set.seed(10101101)

nboot = 100
nobs = length(EQcount)
para.star = matrix(NA, nrow=nboot, ncol = 6)
for (j in 1:nboot){
x.star = pois.HMM.generate_sample(n=nobs, m=2, lambda=lams, Mtrans=mtrans)$y
model <- depmix(x.star ~1, nstates=2, data=data.frame(x.star),
family=poisson())
u = as.vector(getpars(fit(model, verbose=0)))
# make sure state 1 is the one with the smaller intensity parameter
if (u[7] <= u[8]) { para.star[j,] = c(u[3:6], exp(u[7]), exp(u[8])) }
else { para.star[j,] = c(u[6:3], exp(u[8]), exp(u[7])) }
 }
## converged at iteration 28 with logLik: -317.3536 
## converged at iteration 10 with logLik: -336.3123 
## converged at iteration 15 with logLik: -330.7023 
## converged at iteration 16 with logLik: -325.2017 
## converged at iteration 19 with logLik: -334.0389 
## converged at iteration 16 with logLik: -321.5097 
## converged at iteration 25 with logLik: -342.4645 
## converged at iteration 15 with logLik: -323.6899 
## converged at iteration 9 with logLik: -321.6437 
## converged at iteration 18 with logLik: -322.362 
## converged at iteration 12 with logLik: -327.4347 
## converged at iteration 10 with logLik: -317.0057 
## converged at iteration 9 with logLik: -338.8998 
## converged at iteration 12 with logLik: -334.3831 
## converged at iteration 10 with logLik: -320.6662 
## converged at iteration 15 with logLik: -337.1912 
## converged at iteration 14 with logLik: -329.5808 
## converged at iteration 17 with logLik: -323.376 
## converged at iteration 15 with logLik: -327.2818 
## converged at iteration 15 with logLik: -324.8806 
## converged at iteration 12 with logLik: -328.8237 
## converged at iteration 13 with logLik: -323.2429 
## converged at iteration 35 with logLik: -303.1696 
## converged at iteration 14 with logLik: -311.838 
## converged at iteration 20 with logLik: -325.593 
## converged at iteration 25 with logLik: -344.3057 
## converged at iteration 13 with logLik: -336.7609 
## converged at iteration 9 with logLik: -331.3855 
## converged at iteration 16 with logLik: -329.6708 
## converged at iteration 38 with logLik: -320.4871 
## converged at iteration 40 with logLik: -321.4419 
## converged at iteration 20 with logLik: -340.2987 
## converged at iteration 11 with logLik: -316.1531 
## converged at iteration 19 with logLik: -331.9695 
## converged at iteration 15 with logLik: -328.3009 
## converged at iteration 22 with logLik: -336.7947 
## converged at iteration 14 with logLik: -335.777 
## converged at iteration 19 with logLik: -336.8923 
## converged at iteration 17 with logLik: -328.7383 
## converged at iteration 14 with logLik: -338.4921 
## converged at iteration 18 with logLik: -335.8289 
## converged at iteration 13 with logLik: -324.3853 
## converged at iteration 19 with logLik: -332.4478 
## converged at iteration 23 with logLik: -331.5049 
## converged at iteration 18 with logLik: -320.7098 
## converged at iteration 16 with logLik: -333.7366 
## converged at iteration 16 with logLik: -342.2729 
## converged at iteration 13 with logLik: -330.8512 
## converged at iteration 9 with logLik: -323.9359 
## converged at iteration 17 with logLik: -332.7441 
## converged at iteration 24 with logLik: -322.1631 
## converged at iteration 54 with logLik: -324.2249 
## converged at iteration 17 with logLik: -312.7729 
## converged at iteration 13 with logLik: -331.0078 
## converged at iteration 16 with logLik: -320.4881 
## converged at iteration 12 with logLik: -333.6678 
## converged at iteration 17 with logLik: -351.9982 
## converged at iteration 16 with logLik: -312.2302 
## converged at iteration 9 with logLik: -324.7744 
## converged at iteration 11 with logLik: -328.7093 
## converged at iteration 12 with logLik: -326.4755 
## converged at iteration 17 with logLik: -331.4812 
## converged at iteration 13 with logLik: -335.3246 
## converged at iteration 14 with logLik: -320.2642 
## converged at iteration 11 with logLik: -321.1371 
## converged at iteration 22 with logLik: -343.5264 
## converged at iteration 15 with logLik: -344.8566 
## converged at iteration 12 with logLik: -324.5623 
## converged at iteration 13 with logLik: -329.2879 
## converged at iteration 29 with logLik: -343.0569 
## converged at iteration 17 with logLik: -336.5592 
## converged at iteration 20 with logLik: -333.9896 
## converged at iteration 18 with logLik: -341.6623 
## converged at iteration 10 with logLik: -319.5575 
## converged at iteration 10 with logLik: -320.8678 
## converged at iteration 17 with logLik: -335.7764 
## converged at iteration 16 with logLik: -324.6303 
## converged at iteration 13 with logLik: -343.359 
## converged at iteration 14 with logLik: -335.697 
## converged at iteration 167 with logLik: -321.9255 
## converged at iteration 49 with logLik: -309.581 
## converged at iteration 64 with logLik: -337.8977 
## converged at iteration 19 with logLik: -333.5856 
## converged at iteration 26 with logLik: -329.8142 
## converged at iteration 11 with logLik: -333.4356 
## converged at iteration 40 with logLik: -335.0244 
## converged at iteration 15 with logLik: -321.1205 
## converged at iteration 35 with logLik: -326.9086 
## converged at iteration 18 with logLik: -323.0662 
## converged at iteration 18 with logLik: -330.1606 
## converged at iteration 15 with logLik: -320.2706 
## converged at iteration 19 with logLik: -323.3005 
## converged at iteration 15 with logLik: -320.9108 
## converged at iteration 13 with logLik: -326.7983 
## converged at iteration 12 with logLik: -317.1947 
## converged at iteration 14 with logLik: -333.5056 
## converged at iteration 13 with logLik: -329.1758 
## converged at iteration 9 with logLik: -319.8779 
## converged at iteration 13 with logLik: -341.9616 
## converged at iteration 12 with logLik: -321.6762
# bootstrapped std errors
SE = sqrt(apply(para.star,2,var) +
(apply(para.star,2,mean)-para.mle)^2)[c(1,4:6)]
names(SE)=c('seM11/M12', 'seM21/M22', 'seLam1', 'seLam2'); SE
##  seM11/M12  seM21/M22     seLam1     seLam2 
## 0.04074297 0.09218465 0.66300322 1.10658114
library(depmixS4)
y = ts(sp500w, start=2003, freq=52)
 # make data depmix friendly
mod3 <- depmix(y~1, nstates=3, data=data.frame(y))
set.seed(2)
summary(fm3 <- fit(mod3))
## converged at iteration 363 with logLik: 1236.996 
## Initial state probabilities model 
## pr1 pr2 pr3 
##   1   0   0 
## 
## Transition matrix 
##         toS1  toS2  toS3
## fromS1 0.942 0.027 0.032
## fromS2 0.261 0.000 0.739
## fromS3 0.000 0.055 0.945
## 
## Response parameters 
## Resp 1 : gaussian 
##     Re1.(Intercept) Re1.sd
## St1          -0.003  0.044
## St2          -0.034  0.009
## St3           0.004  0.014
##-- Graphics --##
layout(matrix(c(1,2, 1,3), 2), heights=c(1,.75))
par(mar=c(2.5,2.5,.5,.5), mgp=c(1.6,.6,0))
plot(y, main="", ylab='S&P500 Weekly Returns', col=gray(.7),
ylim=c(-.11,.11))
culer = 4-posterior(fm3)[,1]; culer[culer==3]=4 # switch labels 1 and 3
text(y, col=culer, labels=4-posterior(fm3)[,1])
##-- MLEs --##
para.mle = as.vector(getpars(fm3)[-(1:3)])
permu = matrix(c(0,0,1,0,1,0,1,0,0), 3,3)
 # for the label switch
(mtrans.mle = permu%*%round(t(matrix(para.mle[1:9],3,3)),3)%*%permu)
##       [,1]  [,2]  [,3]
## [1,] 0.945 0.055 0.000
## [2,] 0.739 0.000 0.261
## [3,] 0.032 0.027 0.942
(norms.mle = round(matrix(para.mle[10:15],2,3),3)%*%permu)
##       [,1]   [,2]   [,3]
## [1,] 0.004 -0.034 -0.003
## [2,] 0.014  0.009  0.044
acf(y^2, xlim=c(.02,.5), ylim=c(-.09,.5), panel.first=grid(lty=2) )
hist(y, 25, prob=TRUE, main='')
culer=c(1,2,4); pi.hat = colSums(posterior(fm3)[-1,2:4])/length(y)
for (i in 1:3) { mu=norms.mle[1,i]; sig = norms.mle[2,i]
x = seq(-.15,.12, by=.001)
lines(x, pi.hat[4-i]*dnorm(x, mean=mu, sd=sig), col=culer[i])
 }

##-- Bootstrap --##
set.seed(666); n.obs = length(y); n.boot = 100
para.star = matrix(NA, nrow=n.boot, ncol = 15)
respst <- para.mle[10:15]; trst <- para.mle[1:9]
for (nb in 1:n.boot) {
  mod <- simulate(mod3)
y.star = as.vector(mod@response[[1]][[1]]@y)
dfy = data.frame(y.star)
mod.star <- depmix(y.star~1, data=dfy, respst=respst, trst=trst, nst=3)
fm.star = fit(mod.star, emcontrol=em.control(tol = 1e-5), verbose=FALSE)
para.star[nb,] = as.vector(getpars(fm.star)[-(1:3)])
}
## converged at iteration 137 with logLik: -685.0962 
## converged at iteration 40 with logLik: -715.0901 
## converged at iteration 42 with logLik: -711.9793 
## converged at iteration 62 with logLik: -728.6847 
## converged at iteration 47 with logLik: -683.3955 
## converged at iteration 73 with logLik: -719.2561 
## converged at iteration 18 with logLik: -719.1667 
## converged at iteration 10 with logLik: -717.0603 
## converged at iteration 41 with logLik: -713.9096 
## converged at iteration 36 with logLik: -714.0937 
## converged at iteration 61 with logLik: -711.3154 
## converged at iteration 68 with logLik: -689.7452 
## converged at iteration 59 with logLik: -718.1053 
## converged at iteration 68 with logLik: -715.2818 
## converged at iteration 111 with logLik: -725.1249 
## converged at iteration 34 with logLik: -707.9774 
## converged at iteration 37 with logLik: -722.7253 
## converged at iteration 25 with logLik: -721.1461 
## converged at iteration 70 with logLik: -687.7122 
## converged at iteration 89 with logLik: -703.9078 
## converged at iteration 127 with logLik: -712.3814 
## converged at iteration 47 with logLik: -709.9084 
## converged at iteration 49 with logLik: -719.1742 
## converged at iteration 86 with logLik: -716.4459 
## converged at iteration 19 with logLik: -728.5627 
## converged at iteration 117 with logLik: -741.5508 
## converged at iteration 59 with logLik: -724.3466 
## converged at iteration 125 with logLik: -709.3661 
## converged at iteration 29 with logLik: -702.9124 
## converged at iteration 73 with logLik: -723.6699 
## converged at iteration 5 with logLik: -707.7749 
## converged at iteration 30 with logLik: -706.955 
## converged at iteration 68 with logLik: -717.8612 
## converged at iteration 53 with logLik: -699.8133 
## converged at iteration 63 with logLik: -738.885 
## converged at iteration 49 with logLik: -714.506 
## converged at iteration 10 with logLik: -720.1578 
## converged at iteration 4 with logLik: -745.3851 
## converged at iteration 134 with logLik: -736.3881 
## converged at iteration 10 with logLik: -722.0937 
## converged at iteration 26 with logLik: -716.9009 
## converged at iteration 112 with logLik: -719.9439 
## converged at iteration 5 with logLik: -736.8251 
## converged at iteration 4 with logLik: -737.3519 
## converged at iteration 33 with logLik: -717.5958 
## converged at iteration 46 with logLik: -689.7854 
## converged at iteration 67 with logLik: -718.414 
## converged at iteration 203 with logLik: -708.6658 
## converged at iteration 21 with logLik: -720.1915 
## converged at iteration 55 with logLik: -722.1156 
## converged at iteration 129 with logLik: -712.7773 
## converged at iteration 7 with logLik: -716.8763 
## converged at iteration 6 with logLik: -697.5471 
## converged at iteration 26 with logLik: -714.4512 
## converged at iteration 82 with logLik: -746.5156 
## converged at iteration 13 with logLik: -742.0853 
## converged at iteration 30 with logLik: -730.0876 
## converged at iteration 85 with logLik: -700.2979 
## converged at iteration 63 with logLik: -716.1117 
## converged at iteration 18 with logLik: -678.0246 
## converged at iteration 142 with logLik: -719.0167 
## converged at iteration 88 with logLik: -727.6358 
## converged at iteration 13 with logLik: -719.2273 
## converged at iteration 55 with logLik: -727.4717 
## converged at iteration 29 with logLik: -729.9938 
## converged at iteration 41 with logLik: -698.3121 
## converged at iteration 18 with logLik: -717.0544 
## converged at iteration 45 with logLik: -736.7178 
## converged at iteration 86 with logLik: -731.9154 
## converged at iteration 50 with logLik: -705.7303 
## converged at iteration 20 with logLik: -749.1358 
## converged at iteration 75 with logLik: -703.0108 
## converged at iteration 39 with logLik: -696.3187 
## converged at iteration 21 with logLik: -705.1997 
## converged at iteration 79 with logLik: -720.6175 
## converged at iteration 47 with logLik: -667.1072 
## converged at iteration 91 with logLik: -752.0564 
## converged at iteration 99 with logLik: -698.3989 
## converged at iteration 3 with logLik: -717.7247 
## converged at iteration 64 with logLik: -710.3168 
## converged at iteration 144 with logLik: -701.0941 
## converged at iteration 49 with logLik: -742.9761 
## converged at iteration 74 with logLik: -741.614 
## converged at iteration 86 with logLik: -735.7934 
## converged at iteration 179 with logLik: -706.4811 
## converged at iteration 26 with logLik: -713.8593 
## converged at iteration 32 with logLik: -723.8202 
## converged at iteration 93 with logLik: -744.5042 
## converged at iteration 20 with logLik: -731.8394 
## converged at iteration 5 with logLik: -718.826 
## converged at iteration 110 with logLik: -726.9593 
## converged at iteration 66 with logLik: -726.0535 
## converged at iteration 77 with logLik: -724.0721 
## converged at iteration 78 with logLik: -702.4992 
## converged at iteration 92 with logLik: -703.1677 
## converged at iteration 40 with logLik: -709.626 
## converged at iteration 89 with logLik: -741.0967 
## converged at iteration 140 with logLik: -714.3438 
## converged at iteration 186 with logLik: -702.3318 
## converged at iteration 42 with logLik: -733.453
SE = sqrt(apply(para.star,2,var) + (apply(para.star,2,mean)-para.mle)^2)
(SE.mtrans.mle = permu%*%round(t(matrix(SE[1:9],3,3)),3)%*%permu)
##       [,1]  [,2]  [,3]
## [1,] 0.074 0.074 0.000
## [2,] 0.275 0.000 0.275
## [3,] 0.122 0.057 0.147
(SE.norms.mle = round(matrix(SE[10:15], 2,3),3)%*%permu)
##       [,1]  [,2]  [,3]
## [1,] 0.173 0.909 0.317
## [2,] 0.968 0.777 0.910

Example 6.18 Switching AR - Influenza Mortality

library(MSwM)
set.seed(90210)
dflu = diff(flu)
model = lm(dflu~ 1)
mod = msmFit(model, k=2, p=2, sw=rep(TRUE,4))
 # 2 regimes, AR(2)s
summary(mod)
plotProb(mod, which=3)

6.10 Dynamic Linear Models with Switching

Example 6.22 Analysis of the Influenza Data

y = as.matrix(flu); num = length(y); nstate = 4;
M1 = as.matrix(cbind(1,0,0,1)) # obs matrix normal
M2 = as.matrix(cbind(1,0,1,1)) # obs matrix flu epi
prob = matrix(0,num,1); yp = y # to store pi2(t|t-1) & y(t|t-1)
xfilter = array(0, dim=c(nstate,1,num)) # to store x(t|t)
# Function to Calculate Likelihood
Linn = function(para){
alpha1 = para[1]; alpha2 = para[2]; beta0 = para[3]
sQ1 = para[4]; sQ2 = para[5]; like=0
xf = matrix(0, nstate, 1) # x filter
xp = matrix(0, nstate, 1) # x pred
Pf = diag(.1, nstate)
 # filter cov
Pp = diag(.1, nstate)
 # pred cov
pi11 <- .75 -> pi22; pi12 <- .25 -> pi21; pif1 <- .5 -> pif2
phi = matrix(0, nstate, nstate)
phi[1,1] = alpha1; phi[1,2] = alpha2; phi[2,1]=1; phi[4,4]=1
Ups = as.matrix(rbind(0,0,beta0,0))
Q = matrix(0,nstate,nstate)
Q[1,1] = sQ1^2; Q[3,3] = sQ2^2; R=0 # R=0 in final model
# begin filtering #
for(i in 1:num){
xp = phi%*%xf + Ups; Pp = phi%*%Pf%*%t(phi) + Q
sig1 = as.numeric(M1%*%Pp%*%t(M1) + R)
sig2 = as.numeric(M2%*%Pp%*%t(M2) + R)
k1 = Pp%*%t(M1)/sig1; k2 = Pp%*%t(M2)/sig2
e1 = y[i]-M1%*%xp; e2 = y[i]-M2%*%xp
pip1 = pif1*pi11 + pif2*pi21; pip2 = pif1*pi12 + pif2*pi22
den1 = (1/sqrt(sig1))*exp(-.5*e1^2/sig1)
den2 = (1/sqrt(sig2))*exp(-.5*e2^2/sig2)
denm = pip1*den1 + pip2*den2
pif1 = pip1*den1/denm; pif2 = pip2*den2/denm
pif1 = as.numeric(pif1); pif2 = as.numeric(pif2)
e1 = as.numeric(e1); e2=as.numeric(e2)
xf = xp + pif1*k1*e1 + pif2*k2*e2
eye = diag(1, nstate)
Pf = pif1*(eye-k1%*%M1)%*%Pp + pif2*(eye-k2%*%M2)%*%Pp
like = like - log(pip1*den1 + pip2*den2)
prob[i]<<-pip2; xfilter[,,i]<<-xf; innov.sig<<-c(sig1,sig2)
yp[i]<<-ifelse(pip1 > pip2, M1%*%xp, M2%*%xp) }
return(like)
 }
# Estimation
alpha1 = 1.4; alpha2 = -.5; beta0 = .3; sQ1 = .1; sQ2 = .1
init.par = c(alpha1, alpha2, beta0, sQ1, sQ2)
(est = optim(init.par, Linn, NULL, method='BFGS', hessian=TRUE,
control=list(trace=1,REPORT=1)))
## initial  value -236.860522 
## iter   2 value -313.882451
## iter   3 value -320.373891
## iter   4 value -322.538581
## iter   5 value -326.037522
## iter   6 value -326.220434
## iter   7 value -328.165001
## iter   8 value -337.802054
## iter   9 value -339.102455
## iter  10 value -339.278478
## iter  11 value -339.295742
## iter  12 value -339.295935
## iter  13 value -339.295949
## iter  13 value -339.295949
## final  value -339.295949 
## converged
## $par
## [1]  1.40570967 -0.62198715  0.21049042  0.02310306  0.11217287
## 
## $value
## [1] -339.2959
## 
## $counts
## function gradient 
##       67       13 
## 
## $convergence
## [1] 0
## 
## $message
## NULL
## 
## $hessian
##           [,1]       [,2]        [,3]       [,4]       [,5]
## [1,]  781.6937  779.66092   112.58312   1956.837  -32.89720
## [2,]  779.6609 1000.99490    82.68173   -107.393  -53.07502
## [3,]  112.5831   82.68173  1786.32460  -3798.730 -594.69751
## [4,] 1956.8370 -107.39297 -3798.72986 418827.665 7721.44658
## [5,]  -32.8972  -53.07502  -594.69751   7721.447 3892.96236
SE = sqrt(diag(solve(est$hessian)))
u = cbind(estimate=est$par, SE)
rownames(u)=c('alpha1','alpha2','beta0','sQ1','sQ2'); u
##           estimate          SE
## alpha1  1.40570967 0.078587727
## alpha2 -0.62198715 0.068733109
## beta0   0.21049042 0.024625302
## sQ1     0.02310306 0.001635291
## sQ2     0.11217287 0.016684663
# Graphics
predepi = ifelse(prob<.5,0,1); k = 6:length(y)
Time = time(flu)[k]
regime = predepi[k]+1
par(mfrow=c(3,1), mar=c(2,3,1,1)+.1)
plot(Time, y[k], type="n", ylab="")
grid(lty=2); lines(Time, y[k], col=gray(.7))
text(Time, y[k], col=regime, labels=regime, cex=1.1)
text(1979,.95,"(a)")
plot(Time, xfilter[1,,k], type="n", ylim=c(-.1,.4), ylab="")
grid(lty=2); lines(Time, xfilter[1,,k])
lines(Time, xfilter[3,,k]); lines(Time, xfilter[4,,k])
text(1979,.35,"(b)")
plot(Time, y[k], type="n",
 ylim=c(.1,.9),ylab="")
grid(lty=2); points(Time, y[k], pch=19)
prde1 = 2*sqrt(innov.sig[1]); prde2 = 2*sqrt(innov.sig[2])
prde = ifelse(predepi[k]<.5, prde1,prde2)
xx = c(Time, rev(Time))
yy = c(yp[k]-prde, rev(yp[k]+prde))
polygon(xx, yy, border=8, col=gray(.6, alpha=.3))
text(1979,.85,"(c)")

Stochastic Volatility

Example 6.23 Analysis of the New York Stock Exchange Returns

y = log(nyse^2)
num = length(y)
# Initial Parameters
phi0 = 0; phi1 =.95; sQ =.2; alpha = mean(y)
sR0 = 1; mu1 = -3; sR1 =2
init.par = c(phi0, phi1, sQ, alpha, sR0, mu1, sR1)
# Innovations Likelihood
Linn = function(para){
phi0 = para[1]; phi1 = para[2]; sQ = para[3]; alpha = para[4]
sR0 = para[5]; mu1 = para[6]; sR1 = para[7]
sv = SVfilter(num, y, phi0, phi1, sQ, alpha, sR0, mu1, sR1)
return(sv$like)
 }
# Estimation
(est = optim(init.par, Linn, NULL, method='BFGS', hessian=TRUE,
control=list(trace=1,REPORT=1)))
SE = sqrt(diag(solve(est$hessian)))
u = cbind(estimates=est$par, SE)
rownames(u)=c('phi0','phi1','sQ','alpha','sigv0','mu1','sigv1'); u
# Graphics (need filters at the estimated parameters)
phi0 = est$par[1]; phi1 = est$par[2]; sQ = est$par[3]; alpha = est$par[4]
sR0 = est$par[5]; mu1 = est$par[6]; sR1 = est$par[7]
sv = SVfilter(num,y,phi0,phi1,sQ,alpha,sR0,mu1,sR1)
# densities plot (f is chi-sq, fm is fitted mixture)
x = seq(-15,6,by=.01)
f = exp(-.5*(exp(x)-x))/(sqrt(2*pi))
f0 = exp(-.5*(x^2)/sR0^2)/(sR0*sqrt(2*pi))
f1 = exp(-.5*(x-mu1)^2/sR1^2)/(sR1*sqrt(2*pi))
fm = (f0+f1)/2
plot(x, f, type='l'); lines(x, fm, lty=2, lwd=2)
dev.new(); Time=701:1100
plot (Time, nyse[Time], type='l', col=4, lwd=2, ylab='', xlab='',
ylim=c(-.18,.12))
lines(Time, sv$xp[Time]/10, lwd=2, col=6)

Example 6.24 Analysis of the US GNP Growth Rate

n.boot = 500
 # number of bootstrap replicates
tol = sqrt(.Machine$double.eps) # convergence tolerance
gnpgr = diff(log(gnp))
fit = arima(gnpgr, order=c(1,0,0))
y = as.matrix(log(resid(fit)^2))
num = length(y)
plot.ts(y, ylab='')

# Initial Parameters
phi1 = .9; sQ = .5; alpha = mean(y); sR0 = 1; mu1 = -3; sR1 = 2.5
init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)
# Innovations Likelihood
Linn = function(para, y.data){
phi1 = para[1]; sQ = para[2]; alpha = para[3]
sR0 = para[4]; mu1 = para[5];
 sR1 = para[6]
sv = SVfilter(num, y.data, 0, phi1, sQ, alpha, sR0, mu1, sR1)
return(sv$like)
 }
# Estimation
(est = optim(init.par, Linn, NULL, y.data=y, method='BFGS', hessian=TRUE,
control=list(trace=1,REPORT=1)))
## initial  value 138.250771 
## iter   2 value 136.707854
## iter   3 value 135.810810
## iter   4 value 134.224766
## iter   5 value 133.540496
## iter   6 value 133.194597
## iter   7 value 132.616265
## iter   8 value 132.414118
## iter   9 value 132.342973
## iter  10 value 132.320945
## iter  11 value 132.320626
## iter  12 value 132.320600
## iter  13 value 132.320577
## iter  14 value 132.320547
## iter  15 value 132.320544
## iter  16 value 132.320537
## iter  17 value 132.320531
## iter  18 value 132.320528
## iter  19 value 132.320526
## iter  19 value 132.320524
## iter  19 value 132.320524
## final  value 132.320524 
## converged
## $par
## [1]  0.8838776  0.3810748 -9.6536999  0.8345046 -2.3497986  2.4534855
## 
## $value
## [1] 132.3205
## 
## $counts
## function gradient 
##       48       19 
## 
## $convergence
## [1] 0
## 
## $message
## NULL
## 
## $hessian
##            [,1]       [,2]       [,3]        [,4]       [,5]        [,6]
## [1,] 219.624085 89.1260625 -3.4942051  5.65766316  1.0437181  3.55144855
## [2,]  89.126063 69.7230615  0.6077948 24.77517905  0.9450767  3.51244391
## [3,]  -3.494205  0.6077948 10.0545887  3.76577028  1.8819021  1.39433582
## [4,]   5.657663 24.7751790  3.7657703 40.45361590  0.1686128 -0.09642438
## [5,]   1.043718  0.9450767  1.8819021  0.16861275  4.8442677 -1.81998992
## [6,]   3.551449  3.5124439  1.3943358 -0.09642438 -1.8199899 13.25172796
SE = sqrt(diag(solve(est$hessian)))
u = rbind(estimates=est$par, SE)
colnames(u)=c('phi1','sQ','alpha','sig0','mu1','sig1'); round(u, 3)
##            phi1    sQ  alpha  sig0    mu1  sig1
## estimates 0.884 0.381 -9.654 0.835 -2.350 2.453
## SE        0.109 0.221  0.343 0.204  0.495 0.293
# Bootstrap
para.star = matrix(0, n.boot, 6)
 # to store parameter estimates
for (jb in 1:n.boot){
cat('iteration:', jb, '\n')
phi1 = est$par[1]; sQ = est$par[2]; alpha = est$par[3]
sR0 = est$par[4]; mu1 = est$par[5]; sR1 = est$par[6]
Q = sQ^2; R0 = sR0^2; R1 = sR1^2
sv = SVfilter(num, y, 0, phi1, sQ, alpha, sR0, mu1, sR1)
sig0 = sv$Pp+R0; sig1 = sv$Pp+R1;
K0 = sv$Pp/sig0; K1 = sv$Pp/sig1
inn0 = y-sv$xp-alpha; inn1 = y-sv$xp-mu1-alpha
den1 = (1/sqrt(sig1))*exp(-.5*inn1^2/sig1)
den0 = (1/sqrt(sig0))*exp(-.5*inn0^2/sig0)
fpi1 = den1/(den0+den1)
# start resampling at t=4
e0 = inn0/sqrt(sig0); e1 = inn1/sqrt(sig1)
indx = sample(4:num, replace=TRUE)
sinn = cbind(c(e0[1:3], e0[indx]), c(e1[1:3], e1[indx]))
eF = matrix(c(phi1, 1, 0, 0), 2, 2)
xi = cbind(sv$xp,y) # initialize
for (i in 4:num){
 # generate boot sample
G = matrix(c(0, alpha+fpi1[i]*mu1), 2, 1)
h21 = (1-fpi1[i])*sqrt(sig0[i]); h11 = h21*K0[i]
h22 = fpi1[i]*sqrt(sig1[i]); h12 = h22*K1[i]
H = matrix(c(h11,h21,h12,h22),2,2)
xi[i,] = t(eF%*%as.matrix(xi[i-1,],2) + G + H%*%as.matrix(sinn[i,],2))}
# Estimates from boot data
y.star = xi[,2]
phi1=.9; sQ=.5; alpha=mean(y.star); sR0=1; mu1=-3; sR1=2.5
init.par = c(phi1, sQ, alpha, sR0, mu1, sR1)
 # same as for data
est.star = optim(init.par, Linn, NULL, y.data=y.star, method='BFGS',
control=list(reltol=tol))
para.star[jb,] = cbind(est.star$par[1], abs(est.star$par[2]),
est.star$par[3], abs(est.star$par[4]), est.star$par[5],
abs(est.star$par[6])) }
## iteration: 1 
## iteration: 2 
## iteration: 3 
## iteration: 4 
## iteration: 5 
## iteration: 6 
## iteration: 7 
## iteration: 8 
## iteration: 9 
## iteration: 10 
## iteration: 11 
## iteration: 12 
## iteration: 13 
## iteration: 14 
## iteration: 15 
## iteration: 16 
## iteration: 17 
## iteration: 18 
## iteration: 19 
## iteration: 20 
## iteration: 21 
## iteration: 22 
## iteration: 23 
## iteration: 24 
## iteration: 25 
## iteration: 26 
## iteration: 27 
## iteration: 28 
## iteration: 29 
## iteration: 30 
## iteration: 31 
## iteration: 32 
## iteration: 33 
## iteration: 34 
## iteration: 35 
## iteration: 36 
## iteration: 37 
## iteration: 38 
## iteration: 39 
## iteration: 40 
## iteration: 41 
## iteration: 42 
## iteration: 43 
## iteration: 44 
## iteration: 45 
## iteration: 46 
## iteration: 47 
## iteration: 48 
## iteration: 49 
## iteration: 50 
## iteration: 51 
## iteration: 52 
## iteration: 53 
## iteration: 54 
## iteration: 55 
## iteration: 56 
## iteration: 57 
## iteration: 58 
## iteration: 59 
## iteration: 60 
## iteration: 61 
## iteration: 62 
## iteration: 63 
## iteration: 64 
## iteration: 65 
## iteration: 66 
## iteration: 67 
## iteration: 68 
## iteration: 69 
## iteration: 70 
## iteration: 71 
## iteration: 72 
## iteration: 73 
## iteration: 74 
## iteration: 75 
## iteration: 76 
## iteration: 77 
## iteration: 78 
## iteration: 79 
## iteration: 80 
## iteration: 81 
## iteration: 82 
## iteration: 83 
## iteration: 84 
## iteration: 85 
## iteration: 86 
## iteration: 87 
## iteration: 88 
## iteration: 89 
## iteration: 90 
## iteration: 91 
## iteration: 92 
## iteration: 93 
## iteration: 94 
## iteration: 95 
## iteration: 96 
## iteration: 97 
## iteration: 98 
## iteration: 99 
## iteration: 100 
## iteration: 101 
## iteration: 102 
## iteration: 103 
## iteration: 104 
## iteration: 105 
## iteration: 106 
## iteration: 107 
## iteration: 108 
## iteration: 109 
## iteration: 110 
## iteration: 111 
## iteration: 112 
## iteration: 113 
## iteration: 114 
## iteration: 115 
## iteration: 116 
## iteration: 117 
## iteration: 118 
## iteration: 119 
## iteration: 120 
## iteration: 121 
## iteration: 122 
## iteration: 123 
## iteration: 124 
## iteration: 125 
## iteration: 126 
## iteration: 127 
## iteration: 128 
## iteration: 129 
## iteration: 130 
## iteration: 131 
## iteration: 132 
## iteration: 133 
## iteration: 134 
## iteration: 135 
## iteration: 136 
## iteration: 137 
## iteration: 138 
## iteration: 139 
## iteration: 140 
## iteration: 141 
## iteration: 142 
## iteration: 143 
## iteration: 144 
## iteration: 145 
## iteration: 146 
## iteration: 147 
## iteration: 148 
## iteration: 149 
## iteration: 150 
## iteration: 151 
## iteration: 152 
## iteration: 153 
## iteration: 154 
## iteration: 155 
## iteration: 156 
## iteration: 157 
## iteration: 158 
## iteration: 159 
## iteration: 160 
## iteration: 161 
## iteration: 162 
## iteration: 163 
## iteration: 164 
## iteration: 165 
## iteration: 166 
## iteration: 167 
## iteration: 168 
## iteration: 169 
## iteration: 170 
## iteration: 171 
## iteration: 172 
## iteration: 173 
## iteration: 174 
## iteration: 175 
## iteration: 176 
## iteration: 177 
## iteration: 178 
## iteration: 179 
## iteration: 180 
## iteration: 181 
## iteration: 182 
## iteration: 183 
## iteration: 184 
## iteration: 185 
## iteration: 186 
## iteration: 187 
## iteration: 188 
## iteration: 189 
## iteration: 190 
## iteration: 191 
## iteration: 192 
## iteration: 193 
## iteration: 194 
## iteration: 195 
## iteration: 196 
## iteration: 197 
## iteration: 198 
## iteration: 199 
## iteration: 200 
## iteration: 201 
## iteration: 202 
## iteration: 203 
## iteration: 204 
## iteration: 205 
## iteration: 206 
## iteration: 207 
## iteration: 208 
## iteration: 209 
## iteration: 210 
## iteration: 211 
## iteration: 212 
## iteration: 213 
## iteration: 214 
## iteration: 215 
## iteration: 216 
## iteration: 217 
## iteration: 218 
## iteration: 219 
## iteration: 220 
## iteration: 221 
## iteration: 222 
## iteration: 223 
## iteration: 224 
## iteration: 225 
## iteration: 226 
## iteration: 227 
## iteration: 228 
## iteration: 229 
## iteration: 230 
## iteration: 231 
## iteration: 232 
## iteration: 233 
## iteration: 234 
## iteration: 235 
## iteration: 236 
## iteration: 237 
## iteration: 238 
## iteration: 239 
## iteration: 240 
## iteration: 241 
## iteration: 242 
## iteration: 243 
## iteration: 244 
## iteration: 245 
## iteration: 246 
## iteration: 247 
## iteration: 248 
## iteration: 249 
## iteration: 250 
## iteration: 251 
## iteration: 252 
## iteration: 253 
## iteration: 254 
## iteration: 255 
## iteration: 256 
## iteration: 257 
## iteration: 258 
## iteration: 259 
## iteration: 260 
## iteration: 261 
## iteration: 262 
## iteration: 263 
## iteration: 264 
## iteration: 265 
## iteration: 266 
## iteration: 267 
## iteration: 268 
## iteration: 269 
## iteration: 270 
## iteration: 271 
## iteration: 272 
## iteration: 273 
## iteration: 274 
## iteration: 275 
## iteration: 276 
## iteration: 277 
## iteration: 278 
## iteration: 279 
## iteration: 280 
## iteration: 281 
## iteration: 282 
## iteration: 283 
## iteration: 284 
## iteration: 285 
## iteration: 286 
## iteration: 287 
## iteration: 288 
## iteration: 289 
## iteration: 290 
## iteration: 291 
## iteration: 292 
## iteration: 293 
## iteration: 294 
## iteration: 295 
## iteration: 296 
## iteration: 297 
## iteration: 298 
## iteration: 299 
## iteration: 300 
## iteration: 301 
## iteration: 302 
## iteration: 303 
## iteration: 304 
## iteration: 305 
## iteration: 306 
## iteration: 307 
## iteration: 308 
## iteration: 309 
## iteration: 310 
## iteration: 311 
## iteration: 312 
## iteration: 313 
## iteration: 314 
## iteration: 315 
## iteration: 316 
## iteration: 317 
## iteration: 318 
## iteration: 319 
## iteration: 320 
## iteration: 321 
## iteration: 322 
## iteration: 323 
## iteration: 324 
## iteration: 325 
## iteration: 326 
## iteration: 327 
## iteration: 328 
## iteration: 329 
## iteration: 330 
## iteration: 331 
## iteration: 332 
## iteration: 333 
## iteration: 334 
## iteration: 335 
## iteration: 336 
## iteration: 337 
## iteration: 338 
## iteration: 339 
## iteration: 340 
## iteration: 341 
## iteration: 342 
## iteration: 343 
## iteration: 344 
## iteration: 345 
## iteration: 346 
## iteration: 347 
## iteration: 348 
## iteration: 349 
## iteration: 350 
## iteration: 351 
## iteration: 352 
## iteration: 353 
## iteration: 354 
## iteration: 355 
## iteration: 356 
## iteration: 357 
## iteration: 358 
## iteration: 359 
## iteration: 360 
## iteration: 361 
## iteration: 362 
## iteration: 363 
## iteration: 364 
## iteration: 365 
## iteration: 366 
## iteration: 367 
## iteration: 368 
## iteration: 369 
## iteration: 370 
## iteration: 371 
## iteration: 372 
## iteration: 373 
## iteration: 374 
## iteration: 375 
## iteration: 376 
## iteration: 377 
## iteration: 378 
## iteration: 379 
## iteration: 380 
## iteration: 381 
## iteration: 382 
## iteration: 383 
## iteration: 384 
## iteration: 385 
## iteration: 386 
## iteration: 387 
## iteration: 388 
## iteration: 389 
## iteration: 390 
## iteration: 391 
## iteration: 392 
## iteration: 393 
## iteration: 394 
## iteration: 395 
## iteration: 396 
## iteration: 397 
## iteration: 398 
## iteration: 399 
## iteration: 400 
## iteration: 401 
## iteration: 402 
## iteration: 403 
## iteration: 404 
## iteration: 405 
## iteration: 406 
## iteration: 407 
## iteration: 408 
## iteration: 409 
## iteration: 410 
## iteration: 411 
## iteration: 412 
## iteration: 413 
## iteration: 414 
## iteration: 415 
## iteration: 416 
## iteration: 417 
## iteration: 418 
## iteration: 419 
## iteration: 420 
## iteration: 421 
## iteration: 422 
## iteration: 423 
## iteration: 424 
## iteration: 425 
## iteration: 426 
## iteration: 427 
## iteration: 428 
## iteration: 429 
## iteration: 430 
## iteration: 431 
## iteration: 432 
## iteration: 433 
## iteration: 434 
## iteration: 435 
## iteration: 436 
## iteration: 437 
## iteration: 438 
## iteration: 439 
## iteration: 440 
## iteration: 441 
## iteration: 442 
## iteration: 443 
## iteration: 444 
## iteration: 445 
## iteration: 446 
## iteration: 447 
## iteration: 448 
## iteration: 449 
## iteration: 450 
## iteration: 451 
## iteration: 452 
## iteration: 453 
## iteration: 454 
## iteration: 455 
## iteration: 456 
## iteration: 457 
## iteration: 458 
## iteration: 459 
## iteration: 460 
## iteration: 461 
## iteration: 462 
## iteration: 463 
## iteration: 464 
## iteration: 465 
## iteration: 466 
## iteration: 467 
## iteration: 468 
## iteration: 469 
## iteration: 470 
## iteration: 471 
## iteration: 472 
## iteration: 473 
## iteration: 474 
## iteration: 475 
## iteration: 476 
## iteration: 477 
## iteration: 478 
## iteration: 479 
## iteration: 480 
## iteration: 481 
## iteration: 482 
## iteration: 483 
## iteration: 484 
## iteration: 485 
## iteration: 486 
## iteration: 487 
## iteration: 488 
## iteration: 489 
## iteration: 490 
## iteration: 491 
## iteration: 492 
## iteration: 493 
## iteration: 494 
## iteration: 495 
## iteration: 496 
## iteration: 497 
## iteration: 498 
## iteration: 499 
## iteration: 500
# Some summary statistics and graphics
rmse = rep(NA,6) # SEs from the bootstrap
for(i in 1:6){
rmse[i] = sqrt(sum((para.star[,i]-est$par[i])^2)/n.boot)
cat(i, rmse[i],'\n') }
## 1 0.05972712 
## 2 0.3323777 
## 3 1.505038 
## 4 0.5442805 
## 5 0.4137227 
## 6 0.390387
dev.new(); phi = para.star[,1]
hist(phi, 15, prob=TRUE, main='', xlim=c(.4,1.2), xlab='')
xx = seq(.4, 1.2, by=.01)
lines(xx, dnorm(xx, mean=u[1,1], sd=u[2,1]), lty='dashed', lwd=2)

6.12 Bayesian Analysis of State Space Models

Example 6.26 Local Level Model

##-- Notation --##
# y(t) = x(t) + v(t); v(t) ~ iid N(0,V)
# x(t) = x(t-1) + w(t); w(t) ~ iid N(0,W)
# priors: x(0) ~ N(m0,C0); V ~ IG(a,b); W ~ IG(c,d)
# FFBS: x(t|t) ~ N(m,C); x(t|n) ~ N(mm,CC); x(t|t+1) ~ N(a,R)

ffbs = function(y,V,W,m0,C0){
n = length(y); a = rep(0,n); R = rep(0,n)
m = rep(0,n);
C = rep(0,n); B = rep(0,n-1)
H = rep(0,n-1); mm = rep(0,n); CC = rep(0,n)
x = rep(0,n); llike = 0.0
for (t in 1:n){
if(t==1){a[1] = m0; R[1] = C0 + W
}else{ a[t] = m[t-1]; R[t] = C[t-1] + W }
f = a[t]
Q = R[t] + V
A = R[t]/Q
m[t]
 = a[t]+A*(y[t]-f)
C[t]
 = R[t]-Q*A**2
B[t-1] = C[t-1]/R[t]
H[t-1] = C[t-1]-R[t]*B[t-1]**2
llike = llike + dnorm(y[t],f,sqrt(Q),log=TRUE) }
mm[n] = m[n]; CC[n] = C[n]
x[n] = rnorm(1,m[n],sqrt(C[n]))
for (t in (n-1):1){
mm[t] = m[t] + C[t]/R[t+1]*(mm[t+1]-a[t+1])
CC[t] = C[t] - (C[t]^2)/(R[t+1]^2)*(R[t+1]-CC[t+1])
x[t] = rnorm(1,m[t]+B[t]*(x[t+1]-a[t+1]),sqrt(H[t]))
 }
return(list(x=x,m=m,C=C,mm=mm,CC=CC,llike=llike))
 }
# Simulate states and data
set.seed(1); W = 0.5; V = 1.0
n = 100; m0 = 0.0; C0 = 10.0; x0 = 0
w = rnorm(n,0,sqrt(W))
v = rnorm(n,0,sqrt(V))
x = y = rep(0,n)
x[1] = x0 + w[1]
y[1] = x[1] + v[1]
for (t in 2:n){
  x[t] = x[t-1] + w[t]
y[t] = x[t] + v[t]
 }
# actual smoother (for plotting)
ks = Ksmooth0(num=n, y, A=1, m0, C0, Phi=1, cQ=sqrt(W), cR=sqrt(V))
xsmooth = as.vector(ks$xs)
#
run = ffbs(y,V,W,m0,C0)
m = run$m; C = run$C; mm = run$mm
CC = run$CC; L1 = m-2*C; U1 = m+2*C
L2 = mm-2*CC; U2 = mm+2*CC
N = 50
Vs = seq(0.1,2,length=N)
Ws = seq(0.1,2,length=N)
likes = matrix(0,N,N)
for (i in 1:N){
for (j in 1:N){
V = Vs[i]
W = Ws[j]
run = ffbs(y,V,W,m0,C0)
likes[i,j] = run$llike } }
# Hyperparameters
a = 0.01; b = 0.01; c = 0.01; d = 0.01
# MCMC step
set.seed(90210)
burn = 10; M = 1000
niter = burn + M
V1 = V; W1 = W
draws = NULL
all_draws = NULL
for (iter in 1:niter){
run = ffbs(y,V1,W1,m0,C0)
x = run$x
V1 = 1/rgamma(1,a+n/2,b+sum((y-x)^2)/2)
W1 = 1/rgamma(1,c+(n-1)/2,d+sum(diff(x)^2)/2)
draws = rbind(draws,c(V1,W1,x))
 }
all_draws = draws[,1:2]
q025 = function(x){quantile(x,0.025)}
q975 = function(x){quantile(x,0.975)}
draws = draws[(burn+1):(niter),]
xs = draws[,3:(n+2)]
lx = apply(xs,2,q025)
mx = apply(xs,2,mean)
ux = apply(xs,2,q975)
## plot of the data
par(mfrow=c(2,2), mgp=c(1.6,.6,0), mar=c(3,3.2,1,1))
ts.plot(ts(x), ts(y), ylab='', col=c(1,8), lwd=2)
points(y)
legend(0, 11, legend=c("x(t)","y(t)"), lty=1, col=c(1,8), lwd=2, bty="n",
pch=c(-1,1))
contour(Vs, Ws, exp(likes), xlab=expression(sigma[v]^2),
ylab=expression(sigma[w]^2), drawlabels=FALSE, ylim=c(0,1.2))
points(draws[,1:2], pch=16, col=rgb(.9,0,0,0.3), cex=.7)
hist(draws[,1], ylab="Density",main="", xlab=expression(sigma[v]^2))
abline(v=mean(draws[,1]), col=3, lwd=3)
hist(draws[,2],main="", ylab="Density", xlab=expression(sigma[w]^2))
abline(v=mean(draws[,2]), col=3, lwd=3)
## plot states
par(mgp=c(1.6,.6,0), mar=c(2,1,.5,0)+.5)
plot(ts(mx), ylab='', type='n', ylim=c(min(y),max(y)))
grid(lty=2); points(y)
lines(xsmooth, lwd=4, col=rgb(1,0,1,alpha=.4))
lines(mx, col= 4)
xx=c(1:100, 100:1)
yy=c(lx, rev(ux))
polygon(xx, yy, border=NA, col= gray(.6,alpha=.2))
lines(y, col=gray(.4))
legend('topleft', c('true smoother', 'data', 'posterior mean', '95% of
draws'), lty=1, lwd=c(3,1,1,10), pch=c(-1,1,-1,-1), col=c(6,
gray(.4) ,4, gray(.6, alpha=.5)), bg='white' )

Example 6.27 Structural Model

library(plyr)
 # used to view progress (install it if you don't have it)
y = jj
### setup - model and initial parameters
set.seed(90210)
n = length(y)
F = c(1,1,0,0)
 # this is A
G = diag(0,4)
 # G is Phi
G[1,1] = 1.03
G[2,] = c(0,-1,-1,-1); G[3,]=c(0,1,0,0); G[4,]=c(0,0,1,0)
a1 = rbind(.7,0,0,0) # this is mu0
R1 = diag(.04,4)
 # this is Sigma0
V = .1
W11 = .1
W22 = .1
##-- FFBS --##
ffbs = function(y,F,G,V,W11,W22,a1,R1){
n = length(y)
Ws = diag(c(W11,W22,1,1)) # this is Q with 1s as a device only
iW = diag(1/diag(Ws),4)
a = matrix(0,n,4)
 # this is m_t
R = array(0,c(n,4,4))
 # this is V_t
m = matrix(0,n,4)
C = array(0,c(n,4,4))
a[1,] = a1[,1]
R[1,,] = R1
f = t(F)%*%a[1,]
Q = t(F)%*%R[1,,]%*%F + V
A = R[1,,]%*%F/Q[1,1]
m[1,] = a[1,]+A%*%(y[1]-f)
C[1,,] = R[1,,]-A%*%t(A)*Q[1,1]
for (t in 2:n){
a[t,] = G%*%m[t-1,]
R[t,,] = G%*%C[t-1,,]%*%t(G) + Ws
f = t(F)%*%a[t,]
Q = t(F)%*%R[t,,]%*%F + V
A = R[t,,]%*%F/Q[1,1]
m[t,] = a[t,] + A%*%(y[t]-f)
C[t,,] = R[t,,] - A%*%t(A)*Q[1,1]
 }
xb = matrix(0,n,4)
xb[n,] = m[n,] + t(chol(C[n,,]))%*%rnorm(4)
for (t in (n-1):1){
iC = solve(C[t,,])
CCC = solve(t(G)%*%iW%*%G + iC)
mmm = CCC%*%(t(G)%*%iW%*%xb[t+1,] + iC%*%m[t,])
xb[t,] = mmm + t(chol(CCC))%*%rnorm(4) }
return(xb)
 }
##-- Prior hyperparameters --##
# b0 = 0
 # mean for beta = phi -1
# B0 = Inf # var for beta (non-informative => use OLS for sampling beta)
n0 = 10 # use same for all- the prior is 1/Gamma(n0/2, n0*s20_/2)
s20v = .001 # for V
s20w =.05
 # for Ws
##-- MCMC scheme --##
set.seed(90210)
burnin = 100
step = 10
M = 1000
niter = burnin+step*M
pars = matrix(0,niter,4)
xbs = array(0,c(niter,n,4))
pr <- progress_text()
 # displays progress
pr$init(niter)
## 
  |                                                                            
  |                                                                      |   0%
for (iter in 1:niter){
xb = ffbs(y,F,G,V,W11,W22,a1,R1)
u = xb[,1]
yu = diff(u); xu = u[-n]
 # for phihat and se(phihat)
regu = lm(yu~0+xu)
 # est of beta = phi-1
phies = as.vector(coef(summary(regu)))[1:2] + c(1,0) # phi estimate and SE
dft = df.residual(regu)
G[1,1] = phies[1] + rt(1,dft)*phies[2] # use a t
V = 1/rgamma(1, (n0+n)/2, (n0*s20v/2) + sum((y-xb[,1]-xb[,2])^2)/2)
W11 = 1/rgamma(1, (n0+n-1)/2, (n0*s20w/2) +
sum((xb[-1,1]-phies[1]*xb[-n,1])^2)/2)
W22 = 1/rgamma(1, (n0+ n-3)/2, (n0*s20w/2) + sum((xb[4:n,2] +
xb[3:(n-1),2]+ xb[2:(n-2),2] +xb[1:(n-3),2])^2)/2)
xbs[iter,,] = xb
pars[iter,] = c(G[1,1], sqrt(V), sqrt(W11), sqrt(W22))
pr$step()
 }
## 
  |                                                                            
  |                                                                      |   1%
  |                                                                            
  |=                                                                     |   1%
  |                                                                            
  |=                                                                     |   2%
  |                                                                            
  |==                                                                    |   2%
  |                                                                            
  |==                                                                    |   3%
  |                                                                            
  |==                                                                    |   4%
  |                                                                            
  |===                                                                   |   4%
  |                                                                            
  |===                                                                   |   5%
  |                                                                            
  |====                                                                  |   5%
  |                                                                            
  |====                                                                  |   6%
  |                                                                            
  |=====                                                                 |   6%
  |                                                                            
  |=====                                                                 |   7%
  |                                                                            
  |=====                                                                 |   8%
  |                                                                            
  |======                                                                |   8%
  |                                                                            
  |======                                                                |   9%
  |                                                                            
  |=======                                                               |   9%
  |                                                                            
  |=======                                                               |  10%
  |                                                                            
  |=======                                                               |  11%
  |                                                                            
  |========                                                              |  11%
  |                                                                            
  |========                                                              |  12%
  |                                                                            
  |=========                                                             |  12%
  |                                                                            
  |=========                                                             |  13%
  |                                                                            
  |=========                                                             |  14%
  |                                                                            
  |==========                                                            |  14%
  |                                                                            
  |==========                                                            |  15%
  |                                                                            
  |===========                                                           |  15%
  |                                                                            
  |===========                                                           |  16%
  |                                                                            
  |============                                                          |  16%
  |                                                                            
  |============                                                          |  17%
  |                                                                            
  |============                                                          |  18%
  |                                                                            
  |=============                                                         |  18%
  |                                                                            
  |=============                                                         |  19%
  |                                                                            
  |==============                                                        |  19%
  |                                                                            
  |==============                                                        |  20%
  |                                                                            
  |==============                                                        |  21%
  |                                                                            
  |===============                                                       |  21%
  |                                                                            
  |===============                                                       |  22%
  |                                                                            
  |================                                                      |  22%
  |                                                                            
  |================                                                      |  23%
  |                                                                            
  |================                                                      |  24%
  |                                                                            
  |=================                                                     |  24%
  |                                                                            
  |=================                                                     |  25%
  |                                                                            
  |==================                                                    |  25%
  |                                                                            
  |==================                                                    |  26%
  |                                                                            
  |===================                                                   |  26%
  |                                                                            
  |===================                                                   |  27%
  |                                                                            
  |===================                                                   |  28%
  |                                                                            
  |====================                                                  |  28%
  |                                                                            
  |====================                                                  |  29%
  |                                                                            
  |=====================                                                 |  29%
  |                                                                            
  |=====================                                                 |  30%
  |                                                                            
  |=====================                                                 |  31%
  |                                                                            
  |======================                                                |  31%
  |                                                                            
  |======================                                                |  32%
  |                                                                            
  |=======================                                               |  32%
  |                                                                            
  |=======================                                               |  33%
  |                                                                            
  |=======================                                               |  34%
  |                                                                            
  |========================                                              |  34%
  |                                                                            
  |========================                                              |  35%
  |                                                                            
  |=========================                                             |  35%
  |                                                                            
  |=========================                                             |  36%
  |                                                                            
  |==========================                                            |  36%
  |                                                                            
  |==========================                                            |  37%
  |                                                                            
  |==========================                                            |  38%
  |                                                                            
  |===========================                                           |  38%
  |                                                                            
  |===========================                                           |  39%
  |                                                                            
  |============================                                          |  39%
  |                                                                            
  |============================                                          |  40%
  |                                                                            
  |============================                                          |  41%
  |                                                                            
  |=============================                                         |  41%
  |                                                                            
  |=============================                                         |  42%
  |                                                                            
  |==============================                                        |  42%
  |                                                                            
  |==============================                                        |  43%
  |                                                                            
  |==============================                                        |  44%
  |                                                                            
  |===============================                                       |  44%
  |                                                                            
  |===============================                                       |  45%
  |                                                                            
  |================================                                      |  45%
  |                                                                            
  |================================                                      |  46%
  |                                                                            
  |=================================                                     |  46%
  |                                                                            
  |=================================                                     |  47%
  |                                                                            
  |=================================                                     |  48%
  |                                                                            
  |==================================                                    |  48%
  |                                                                            
  |==================================                                    |  49%
  |                                                                            
  |===================================                                   |  49%
  |                                                                            
  |===================================                                   |  50%
  |                                                                            
  |===================================                                   |  51%
  |                                                                            
  |====================================                                  |  51%
  |                                                                            
  |====================================                                  |  52%
  |                                                                            
  |=====================================                                 |  52%
  |                                                                            
  |=====================================                                 |  53%
  |                                                                            
  |=====================================                                 |  54%
  |                                                                            
  |======================================                                |  54%
  |                                                                            
  |======================================                                |  55%
  |                                                                            
  |=======================================                               |  55%
  |                                                                            
  |=======================================                               |  56%
  |                                                                            
  |========================================                              |  56%
  |                                                                            
  |========================================                              |  57%
  |                                                                            
  |========================================                              |  58%
  |                                                                            
  |=========================================                             |  58%
  |                                                                            
  |=========================================                             |  59%
  |                                                                            
  |==========================================                            |  59%
  |                                                                            
  |==========================================                            |  60%
  |                                                                            
  |==========================================                            |  61%
  |                                                                            
  |===========================================                           |  61%
  |                                                                            
  |===========================================                           |  62%
  |                                                                            
  |============================================                          |  62%
  |                                                                            
  |============================================                          |  63%
  |                                                                            
  |============================================                          |  64%
  |                                                                            
  |=============================================                         |  64%
  |                                                                            
  |=============================================                         |  65%
  |                                                                            
  |==============================================                        |  65%
  |                                                                            
  |==============================================                        |  66%
  |                                                                            
  |===============================================                       |  66%
  |                                                                            
  |===============================================                       |  67%
  |                                                                            
  |===============================================                       |  68%
  |                                                                            
  |================================================                      |  68%
  |                                                                            
  |================================================                      |  69%
  |                                                                            
  |=================================================                     |  69%
  |                                                                            
  |=================================================                     |  70%
  |                                                                            
  |=================================================                     |  71%
  |                                                                            
  |==================================================                    |  71%
  |                                                                            
  |==================================================                    |  72%
  |                                                                            
  |===================================================                   |  72%
  |                                                                            
  |===================================================                   |  73%
  |                                                                            
  |===================================================                   |  74%
  |                                                                            
  |====================================================                  |  74%
  |                                                                            
  |====================================================                  |  75%
  |                                                                            
  |=====================================================                 |  75%
  |                                                                            
  |=====================================================                 |  76%
  |                                                                            
  |======================================================                |  76%
  |                                                                            
  |======================================================                |  77%
  |                                                                            
  |======================================================                |  78%
  |                                                                            
  |=======================================================               |  78%
  |                                                                            
  |=======================================================               |  79%
  |                                                                            
  |========================================================              |  79%
  |                                                                            
  |========================================================              |  80%
  |                                                                            
  |========================================================              |  81%
  |                                                                            
  |=========================================================             |  81%
  |                                                                            
  |=========================================================             |  82%
  |                                                                            
  |==========================================================            |  82%
  |                                                                            
  |==========================================================            |  83%
  |                                                                            
  |==========================================================            |  84%
  |                                                                            
  |===========================================================           |  84%
  |                                                                            
  |===========================================================           |  85%
  |                                                                            
  |============================================================          |  85%
  |                                                                            
  |============================================================          |  86%
  |                                                                            
  |=============================================================         |  86%
  |                                                                            
  |=============================================================         |  87%
  |                                                                            
  |=============================================================         |  88%
  |                                                                            
  |==============================================================        |  88%
  |                                                                            
  |==============================================================        |  89%
  |                                                                            
  |===============================================================       |  89%
  |                                                                            
  |===============================================================       |  90%
  |                                                                            
  |===============================================================       |  91%
  |                                                                            
  |================================================================      |  91%
  |                                                                            
  |================================================================      |  92%
  |                                                                            
  |=================================================================     |  92%
  |                                                                            
  |=================================================================     |  93%
  |                                                                            
  |=================================================================     |  94%
  |                                                                            
  |==================================================================    |  94%
  |                                                                            
  |==================================================================    |  95%
  |                                                                            
  |===================================================================   |  95%
  |                                                                            
  |===================================================================   |  96%
  |                                                                            
  |====================================================================  |  96%
  |                                                                            
  |====================================================================  |  97%
  |                                                                            
  |====================================================================  |  98%
  |                                                                            
  |===================================================================== |  98%
  |                                                                            
  |===================================================================== |  99%
  |                                                                            
  |======================================================================|  99%
  |                                                                            
  |======================================================================| 100%
# Plot results
ind = seq(burnin+1,niter,by=step)
names= c(expression(phi), expression(sigma[v]), expression(sigma[w~11]),
expression(sigma[w~22]))
dev.new(height=5)
par(mfcol=c(3,4), mar=c(2,2,.25,0)+.75, mgp=c(1.6,.6,0), oma=c(0,0,1,0))
for (i in 1:4){
plot.ts(pars[ind,i],xlab="iterations", ylab="trace", main="")
mtext(names[i], side=3, line=.5, cex=1)
acf(pars[ind,i],main="", lag.max=25, xlim=c(1,25), ylim=c(-.4,.4))
hist(pars[ind,i],main="",xlab="")
abline(v=mean(pars[ind,i]), lwd=2, col=3) }
par(mfrow=c(2,1), mar=c(2,2,0,0)+.7, mgp=c(1.6,.6,0))
mxb = cbind(apply(xbs[ind,,1],2,mean), apply(xbs[,,2],2,mean))
lxb = cbind(apply(xbs[ind,,1],2,quantile,0.005),
apply(xbs[ind,,2],2,quantile,0.005))
uxb = cbind(apply(xbs[ind,,1],2,quantile,0.995),
apply(xbs[ind,,2],2,quantile,0.995))
mxb = ts(cbind(mxb,rowSums(mxb)), start = tsp(jj)[1], freq=4)
lxb = ts(cbind(lxb,rowSums(lxb)), start = tsp(jj)[1], freq=4)
uxb = ts(cbind(uxb,rowSums(uxb)), start = tsp(jj)[1], freq=4)
names=c('Trend', 'Season', 'Trend + Season')
L = min(lxb[,1])-.01; U = max(uxb[,1]) +.01
plot(mxb[,1], ylab=names[1], ylim=c(L,U), type='n')
grid(lty=2); lines(mxb[,1])
xx=c(time(jj), rev(time(jj)))
yy=c(lxb[,1], rev(uxb[,1]))
polygon(xx, yy, border=NA, col=gray(.4, alpha = .2))
L = min(lxb[,3])-.01; U = max(uxb[,3]) +.01
plot(mxb[,3], ylab=names[3], ylim=c(L,U), type='n')
grid(lty=2); lines(mxb[,3])
xx=c(time(jj), rev(time(jj)))
yy=c(lxb[,3], rev(uxb[,3]))
polygon(xx, yy, border=NA, col=gray(.4, alpha = .2))

Chapter 7 Statistical Methods in the Frequency Domain

7.1 Introduction

# figure 7.1
x = matrix(0, 128, 6)
for (i in 1:6) { x[,i] = rowMeans(fmri[[i]]) }
colnames(x) = c("Brush", "Heat", "Shock", "Brush", "Heat", "Shock")
plot.ts(x, main="")
mtext("Awake", side=3, line=1.2, adj=.05, cex=1.2)
mtext("Sedated", side=3, line=1.2, adj=.85, cex=1.2)

# figure 7.2
attach(eqexp)
## The following object is masked from package:astsa:
## 
##     EQ5
 # so you can use the names of the series
P = 1:1024; S = P+1024
x = cbind(EQ5[P], EQ6[P], EX5[P], EX6[P], NZ[P], EQ5[S], EQ6[S], EX5[S],
EX6[S], NZ[S])
x.name = c("EQ5","EQ6","EX5","EX6","NZ")
colnames(x) = c(x.name, x.name)
plot.ts(x, main="")
mtext("P waves", side=3, line=1.2, adj=.05, cex=1.2)
mtext("S waves", side=3, line=1.2, adj=.85, cex=1.2)

7.2 Spectral Matrices and Likelihood Functions

7.3 Regression for Jointly Stationary Series

Example 7.1 Predicting Lake Shasta Inflow

plot.ts(climhyd)

 # Figure 7.3
Y = climhyd
 # Y holds the transformed series
Y[,6] = log(Y[,6]) # log inflow
Y[,5] = sqrt(Y[,5]) # sqrt precipitation
L = 25; M = 100; alpha = .001; fdr = .001
nq = 2
 # number of inputs (Temp and Precip)
# Spectral Matrix
Yspec = mvspec(Y, spans=L, kernel="daniell", detrend=TRUE, demean=FALSE,
taper=.1)

n = Yspec$n.used
 # effective sample size
Fr = Yspec$freq
 # fundamental freqs
n.freq = length(Fr)
 # number of frequencies
Yspec$bandwidth*sqrt(12) # = 0.050 - the bandwidth
## [1] 0.1768903
# Coherencies
Fq = qf(1-alpha, 2, L-2)
cn = Fq/(L-1+Fq)
plt.name = c("(a)","(b)","(c)","(d)","(e)","(f)")
dev.new(); par(mfrow=c(2,3), cex.lab=1.2)
# The coherencies are listed as 1,2,...,15=choose(6,2)
for (i in 11:15){
plot(Fr, Yspec$coh[,i], type="l", ylab="Sq Coherence", xlab="Frequency",
ylim=c(0,1), main=c("Inflow with", names(climhyd[i-10])))
abline(h = cn); text(.45,.98, plt.name[i-10], cex=1.2) }
# Multiple Coherency
coh.15 = stoch.reg(Y, cols.full = c(1,5), cols.red = NULL, alpha, L, M,
plot.which = "coh")
text(.45 ,.98, plt.name[6], cex=1.2)
title(main = c("Inflow with", "Temp and Precip"))
# Partial F (called eF; avoid use of F alone)
numer.df = 2*nq; denom.df = Yspec$df-2*nq
dev.new()
par(mfrow=c(3,1), mar=c(3,3,2,1)+.5, mgp = c(1.5,0.4,0), cex.lab=1.2)
out.15 = stoch.reg(Y, cols.full = c(1,5), cols.red = 5, alpha, L, M,
plot.which = "F.stat")
eF = out.15$eF
pvals = pf(eF, numer.df, denom.df, lower.tail = FALSE)
pID = FDR(pvals, fdr); abline(h=c(eF[pID]), lty=2)
title(main = "Partial F Statistic")
# Regression Coefficients
S = seq(from = -M/2+1, to = M/2 - 1, length = M-1)
plot(S, coh.15$Betahat[,1], type = "h", xlab = "", ylab = names(climhyd[1]),
ylim = c(-.025, .055), lwd=2)
abline(h=0); title(main = "Impulse Response Functions")
plot(S, coh.15$Betahat[,2], type = "h", xlab = "Index", ylab =
names(climhyd[5]), ylim = c(-.015, .055), lwd=2)
abline(h=0)

7.4 Regression with Deterministic Inputs

Example 7.2 An Infrasonic Signal from a Nuclear Explosion.

attach(beamd)
tau = rep(0,3)
u = ccf(sensor1, sensor2, plot=FALSE)
tau[1] = u$lag[which.max(u$acf)]
 # 17
u = ccf(sensor3, sensor2, plot=FALSE)
tau[3] = u$lag[which.max(u$acf)]
 # -22
Y = ts.union(lag(sensor1,tau[1]), lag(sensor2, tau[2]), lag(sensor3, tau[3]))
Y = ts.union(Y, rowMeans(Y))
colnames(Y) = c('sensor1', 'sensor2', 'sensor3', 'beam')
plot.ts(Y)

Example 7.4 Detecting the Infrasonic Signal Using ANOPOW

attach(beamd)
## The following objects are masked from beamd (pos = 3):
## 
##     sensor1, sensor2, sensor3
L = 9; fdr = .001; N = 3
Y = cbind(beamd, beam=rowMeans(beamd) )
n = nextn(nrow(Y))
Y.fft = mvfft(as.ts(Y))/sqrt(n)
Df = Y.fft[,1:3] # fft of the data
Bf = Y.fft[,4]
 # beam fft
ssr = N*Re(Bf*Conj(Bf))
 # raw signal spectrum
sse = Re(rowSums(Df*Conj(Df))) - ssr # raw error spectrum
# Smooth
SSE = filter(sse, sides=2, filter=rep(1/L,L), circular=TRUE)
SSR = filter(ssr, sides=2, filter=rep(1/L,L), circular=TRUE)
SST = SSE + SSR
par(mfrow=c(2,1), mar=c(4,4,2,1)+.1)
Fr = 0:(n-1)/n
 # the fundamental frequencies
nFr = 1:200
 # number of freqs to plot
plot(Fr[nFr], SST[nFr], type="l", ylab="log Power", xlab="", main="Sum of
Squares", log="y")
lines(Fr[nFr], SSE[nFr], type="l", lty=2)
eF = (N-1)*SSR/SSE; df1 = 2*L; df2 = 2*L*(N-1)
pvals = pf(eF, df1, df2, lower=FALSE) # p values for FDR
pID = FDR(pvals, fdr); Fq = qf(1-fdr, df1, df2)
plot(Fr[nFr], eF[nFr], type="l", ylab="F-statistic", xlab="Frequency",
main="F Statistic")
abline(h=c(Fq, eF[pID]), lty=1:2)

7.5 Random Coefficient Regression

Example 7.6 Means Test for the fMRI Data

n = 128
 # length of series
n.freq = 1 + n/2
# number of frequencies
Fr = (0:(n.freq-1))/n
# the frequencies
N = c(5,4,5,3,5,4)
 # number of series for each cell
n.subject = sum(N)
 # number of subjects (26)
n.trt = 6
 # number of treatments
L = 3
 # for smoothing
num.df = 2*L*(n.trt-1)
 # df for F test
den.df = 2*L*(n.subject-n.trt)
# Design Matrix (Z):
Z1 = outer(rep(1,N[1]), c(1,1,0,0,0,0))
Z2 = outer(rep(1,N[2]), c(1,0,1,0,0,0))
Z3 = outer(rep(1,N[3]), c(1,0,0,1,0,0))
Z4 = outer(rep(1,N[4]), c(1,0,0,0,1,0))
Z5 = outer(rep(1,N[5]), c(1,0,0,0,0,1))
Z6 = outer(rep(1,N[6]), c(1,-1,-1,-1,-1,-1))
Z = rbind(Z1, Z2, Z3, Z4, Z5, Z6)
ZZ = t(Z)%*%Z
SSEF <- rep(NA, n) -> SSER
HatF = Z%*%solve(ZZ, t(Z))
HatR = Z[,1]%*%t(Z[,1])/ZZ[1,1]
par(mfrow=c(3,3), mar=c(3.5,4,0,0), oma=c(0,0,2,2), mgp = c(1.6,.6,0))
loc.name = c("Cortex 1","Cortex 2","Cortex 3","Cortex 4","Caudate","Thalamus
1","Thalamus 2","Cerebellum 1","Cerebellum 2")
for(Loc in 1:9) {
i = n.trt*(Loc-1)
Y = cbind(fmri[[i+1]], fmri[[i+2]], fmri[[i+3]], fmri[[i+4]], fmri[[i+5]],
fmri[[i+6]])
Y = mvfft(spec.taper(Y, p=.5))/sqrt(n)
Y = t(Y)
 # Y is now 26 x 128 FFTs
# Calculation of Error Spectra
for (k in 1:n) {
SSY = Re(Conj(t(Y[,k]))%*%Y[,k])
SSReg = Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
SSEF[k] = SSY - SSReg
SSReg = Re(Conj(t(Y[,k]))%*%HatR%*%Y[,k])
SSER[k]
 = SSY - SSReg
 }
# Smooth
sSSEF = filter(SSEF, rep(1/L, L), circular = TRUE)
sSSER = filter(SSER, rep(1/L, L), circular = TRUE)
eF = (den.df/num.df)*(sSSER-sSSEF)/sSSEF
plot(Fr,
 eF[1:n.freq], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,7))
abline(h=qf(.999, num.df, den.df),lty=2)
text(.25, 6.5, loc.name[Loc], cex=1.2)
 }

Moving into ANOVA (i.e. treatment effects) Models

Example 7.77 Analysis of Power Tests for the fMRI Series

n = 128
n.freq = 1 + n/2
Fr = (0:(n.freq-1))/n
nFr = 1:(n.freq/2)
N = c(5,4,5,3,5,4)
n.subject = sum(N)
n.para = 6
 # number of parameters
L = 3
 # for smoothing
df.stm = 2*L*(3-1)
 # stimulus (3 levels: Brush,Heat,Shock)
df.con = 2*L*(2-1)
 # conscious (2 levels: Awake,Sedated)
df.int = 2*L*(3-1)*(2-1) # interaction
den.df = 2*L*(n.subject-n.para) # df for full model
Z1 = outer(rep(1,N[1]), c(1, 1, 0, 1, 1, 0))
Z2 = outer(rep(1,N[2]), c(1, 0, 1, 1, 0, 1))
Z3 = outer(rep(1,N[3]), c(1, -1, -1, 1, -1, -1))
Z4 = outer(rep(1,N[4]), c(1, 1, 0, -1, -1, 0))
Z5 = outer(rep(1,N[5]), c(1, 0, 1, -1, 0, -1))
Z6 = outer(rep(1,N[6]), c(1, -1, -1, -1, 1, 1))
Z = rbind(Z1, Z2, Z3, Z4, Z5, Z6)
ZZ = t(Z)%*%Z
rep(NA, n)-> SSEF-> SSE.stm-> SSE.con-> SSE.int
HatF = Z%*%solve(ZZ,t(Z))
Hat.stm = Z[,-(2:3)]%*%solve(ZZ[-(2:3),-(2:3)], t(Z[,-(2:3)]))
Hat.con = Z[,-4]%*%solve(ZZ[-4,-4], t(Z[,-4]))
Hat.int = Z[,-(5:6)]%*%solve(ZZ[-(5:6),-(5:6)], t(Z[,-(5:6)]))
par(mfrow=c(5,3), mar=c(3.5,4,0,0), oma=c(0,0,2,2), mgp = c(1.6,.6,0))
loc.name = c("Cortex 1","Cortex 2","Cortex 3","Cortex 4","Caudate", "
Thalamus 1","Thalamus 2","Cerebellum 1","Cerebellum 2")
for(Loc in c(1:4,9)) {
 # only Loc 1 to 4 and 9 used
i = 6*(Loc-1)
Y = cbind(fmri[[i+1]], fmri[[i+2]], fmri[[i+3]], fmri[[i+4]], fmri[[i+5]],
fmri[[i+6]])
Y = mvfft(spec.taper(Y, p=.5))/sqrt(n); Y = t(Y)
for (k in 1:n) {
SSY = Re(Conj(t(Y[,k]))%*%Y[,k])
SSReg = Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
SSEF[k] = SSY - SSReg
SSReg = Re(Conj(t(Y[,k]))%*%Hat.stm%*%Y[,k])
SSE.stm[k] = SSY-SSReg
SSReg = Re(Conj(t(Y[,k]))%*%Hat.con%*%Y[,k])
SSE.con[k] = SSY-SSReg
SSReg = Re(Conj(t(Y[,k]))%*%Hat.int%*%Y[,k])
SSE.int[k] = SSY-SSReg
 }
# Smooth
sSSEF = filter(SSEF, rep(1/L, L), circular = TRUE)
sSSE.stm = filter(SSE.stm, rep(1/L, L), circular = TRUE)
sSSE.con = filter(SSE.con, rep(1/L, L), circular = TRUE)
sSSE.int = filter(SSE.int, rep(1/L, L), circular = TRUE)
eF.stm = (den.df/df.stm)*(sSSE.stm-sSSEF)/sSSEF
eF.con = (den.df/df.con)*(sSSE.con-sSSEF)/sSSEF
eF.int = (den.df/df.int)*(sSSE.int-sSSEF)/sSSEF
plot(Fr[nFr],eF.stm[nFr], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,12))
abline(h = qf(.999, df.stm, den.df), lty = 2)
if(Loc==1) mtext("Stimulus", side=3, line=.3, cex=1)
mtext(loc.name[Loc], side=2, line=3, cex=.9)
plot(Fr[nFr], eF.con[nFr], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,12))
abline(h=qf(.999, df.con, den.df),lty=2)
if(Loc==1) mtext("Consciousness", side=3, line=.3, cex=1)
plot(Fr[nFr], eF.int[nFr], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,12))
abline(h=qf(.999, df.int, den.df),lty=2)
if(Loc==1) mtext("Interaction", side=3, line= .3, cex=1)
 }

Example 7.8 Simultaneous Inference for the fMRI series

n = 128; n.freq = 1 + n/2
Fr = (0:(n.freq-1))/n; nFr = 1:(n.freq/2)
N = c(5,4,5,3,5,4); n.subject = sum(N); L = 3
# Design Matrix
Z1 = outer(rep(1,N[1]), c(1,0,0,0,0,0))
Z2 = outer(rep(1,N[2]), c(0,1,0,0,0,0))
Z3 = outer(rep(1,N[3]), c(0,0,1,0,0,0))
Z4 = outer(rep(1,N[4]), c(0,0,0,1,0,0))
Z5 = outer(rep(1,N[5]), c(0,0,0,0,1,0))
Z6 = outer(rep(1,N[6]), c(0,0,0,0,0,1))
Z = rbind(Z1, Z2, Z3, Z4, Z5, Z6); ZZ = t(Z)%*%Z
# Contrasts: 6 by 3
A = rbind(diag(1,3), diag(1,3))
nq = nrow(A); num.df = 2*L*nq; den.df = 2*L*(n.subject-nq)
HatF = Z%*%solve(ZZ, t(Z))
 # full model
rep(NA, n)-> SSEF -> SSER; eF = matrix(0,n,3)
par(mfrow=c(5,3), mar=c(3.5,4,0,0), oma=c(0,0,2,2), mgp = c(1.6,.6,0))
loc.name = c("Cortex 1", "Cortex 2", "Cortex 3", "Cortex 4", "Caudate", "
Thalamus 1", "Thalamus 2", "Cerebellum 1", "Cerebellum 2")
cond.name = c("Brush", "Heat", "Shock")
for(Loc in c(1:4,9)) {
i = 6*(Loc-1)
Y = cbind(fmri[[i+1]], fmri[[i+2]], fmri[[i+3]], fmri[[i+4]], fmri[[i+5]],
fmri[[i+6]])
Y = mvfft(spec.taper(Y, p=.5))/sqrt(n); Y = t(Y)
for (cond in 1:3){
Q = t(A[,cond])%*%solve(ZZ, A[,cond])
HR = A[,cond]%*%solve(ZZ, t(Z))
for (k in 1:n){
SSY = Re(Conj(t(Y[,k]))%*%Y[,k])
SSReg = Re(Conj(t(Y[,k]))%*%HatF%*%Y[,k])
SSEF[k] = (SSY-SSReg)*Q
SSReg = HR%*%Y[,k]
SSER[k] = Re(SSReg*Conj(SSReg)) }
# Smooth
sSSEF = filter(SSEF, rep(1/L, L), circular = TRUE)
sSSER = filter(SSER, rep(1/L, L), circular = TRUE)
eF[,cond] = (den.df/num.df)*(sSSER/sSSEF)
 }
plot(Fr[nFr], eF[nFr,1], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,5))
abline(h=qf(.999, num.df, den.df),lty=2)
if(Loc==1) mtext("Brush", side=3, line=.3, cex=1)
mtext(loc.name[Loc], side=2, line=3, cex=.9)
plot(Fr[nFr], eF[nFr,2], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,5))
abline(h=qf(.999, num.df, den.df),lty=2)
if(Loc==1) mtext("Heat", side=3, line=.3, cex=1)
plot(Fr[nFr], eF[nFr,3], type="l", xlab="Frequency", ylab="F Statistic",
ylim=c(0,5))
abline(h = qf(.999, num.df, den.df) ,lty=2)
if(Loc==1) mtext("Shock", side=3, line=.3, cex=1) }

Example 7.9 Equality of Means and Spectral Matrices

P = 1:1024; S = P+1024; N = 8; n = 1024; p.dim = 2; m = 10; L = 2*m+1
eq.P = as.ts(eqexp[P,1:8]); eq.S = as.ts(eqexp[S,1:8])
eq.m = cbind(rowMeans(eq.P), rowMeans(eq.S))
ex.P = as.ts(eqexp[P,9:16]); ex.S = as.ts(eqexp[S,9:16])
ex.m = cbind(rowMeans(ex.P), rowMeans(ex.S))
m.diff = mvfft(eq.m - ex.m)/sqrt(n)
eq.Pf = mvfft(eq.P-eq.m[,1])/sqrt(n)
eq.Sf = mvfft(eq.S-eq.m[,2])/sqrt(n)
ex.Pf = mvfft(ex.P-ex.m[,1])/sqrt(n)
ex.Sf = mvfft(ex.S-ex.m[,2])/sqrt(n)
fv11 = rowSums(eq.Pf*Conj(eq.Pf))+rowSums(ex.Pf*Conj(ex.Pf))/(2*(N-1))
fv12 = rowSums(eq.Pf*Conj(eq.Sf))+rowSums(ex.Pf*Conj(ex.Sf))/(2*(N-1))
fv22 = rowSums(eq.Sf*Conj(eq.Sf))+rowSums(ex.Sf*Conj(ex.Sf))/(2*(N-1))
fv21 = Conj(fv12)
# Equal Means
T2 = rep(NA, 512)
for (k in 1:512){ 
fvk = matrix(c(fv11[k], fv21[k], fv12[k], fv22[k]), 2, 2)
dk = as.matrix(m.diff[k,])
T2[k] = Re((N/2)*Conj(t(dk))%*%solve(fvk,dk)) }
eF = T2*(2*p.dim*(N-1))/(2*N-p.dim-1)
par(mfrow=c(2,2), mar=c(3,3,2,1), mgp = c(1.6,.6,0), cex.main=1.1)
freq = 40*(0:511)/n # Hz
plot(freq, eF, type="l", xlab="Frequency (Hz)", ylab="F Statistic",
main="Equal Means")
abline(h = qf(.999, 2*p.dim, 2*(2*N-p.dim-1)))
# Equal P
kd = kernel("daniell",m);
u = Re(rowSums(eq.Pf*Conj(eq.Pf))/(N-1))
feq.P = kernapply(u, kd, circular=TRUE)
u = Re(rowSums(ex.Pf*Conj(ex.Pf))/(N-1))
fex.P = kernapply(u, kd, circular=TRUE)
plot(freq, feq.P[1:512]/fex.P[1:512], type="l", xlab="Frequency (Hz)",
ylab="F Statistic", main="Equal P-Spectra")
abline(h=qf(.999, 2*L*(N-1), 2*L*(N-1)))
# Equal S
u = Re(rowSums(eq.Sf*Conj(eq.Sf))/(N-1))
feq.S = kernapply(u, kd, circular=TRUE)
u = Re(rowSums(ex.Sf*Conj(ex.Sf))/(N-1))
fex.S = kernapply(u, kd, circular=TRUE)
plot(freq, feq.S[1:512]/fex.S[1:512], type="l", xlab="Frequency (Hz)",
ylab="F Statistic", main="Equal S-Spectra")
abline(h=qf(.999, 2*L*(N-1), 2*L*(N-1)))
# Equal Spectra
u = rowSums(eq.Pf*Conj(eq.Sf))/(N-1)
feq.PS = kernapply(u, kd, circular=TRUE)
u = rowSums(ex.Pf*Conj(ex.Sf)/(N-1))
fex.PS = kernapply(u, kd, circular=TRUE)
fv11 = kernapply(fv11, kd, circular=TRUE)
fv22 = kernapply(fv22, kd, circular=TRUE)
fv12 = kernapply(fv12, kd, circular=TRUE)
Mi = L*(N-1); M = 2*Mi
TS = rep(NA,512)
for (k in 1:512){
det.feq.k = Re(feq.P[k]*feq.S[k] - feq.PS[k]*Conj(feq.PS[k]))
det.fex.k = Re(fex.P[k]*fex.S[k] - fex.PS[k]*Conj(fex.PS[k]))
det.fv.k = Re(fv11[k]*fv22[k] - fv12[k]*Conj(fv12[k]))
log.n1 = log(M)*(M*p.dim); log.d1 = log(Mi)*(2*Mi*p.dim)
log.n2 = log(Mi)*2 +log(det.feq.k)*Mi + log(det.fex.k)*Mi
log.d2 = (log(M)+log(det.fv.k))*M
r = 1 - ((p.dim+1)*(p.dim-1)/6*p.dim*(2-1))*(2/Mi - 1/M)
TS[k] = -2*r*(log.n1+log.n2-log.d1-log.d2)
 }
plot(freq, TS, type="l", xlab="Frequency (Hz)", ylab="Chi-Sq Statistic",
main="Equal Spectral Matrices")
abline(h = qchisq(.9999, p.dim^2))

7.7 Discriminant and Cluster Analysis

Example 7.10 Discriminant Analysis Using Amplitudes

P = 1:1024; S = P+1024
mag.P = log10(apply(eqexp[P,], 2, max) - apply(eqexp[P,], 2, min))
mag.S = log10(apply(eqexp[S,], 2, max) - apply(eqexp[S,], 2, min))
eq.P = mag.P[1:8]; eq.S = mag.S[1:8]
ex.P = mag.P[9:16]; ex.S = mag.S[9:16]
NZ.P = mag.P[17];
NZ.S = mag.S[17]
# Compute linear discriminant function
cov.eq = var(cbind(eq.P, eq.S))
cov.ex = var(cbind(ex.P, ex.S))
cov.pooled = (cov.ex + cov.eq)/2
means.eq = colMeans(cbind(eq.P, eq.S))
means.ex = colMeans(cbind(ex.P, ex.S))
slopes.eq = solve(cov.pooled, means.eq)
inter.eq = -sum(slopes.eq*means.eq)/2
slopes.ex = solve(cov.pooled, means.ex)
inter.ex = -sum(slopes.ex*means.ex)/2
d.slopes = slopes.eq - slopes.ex
d.inter = inter.eq - inter.ex
# Classify new observation
new.data = cbind(NZ.P, NZ.S)
d = sum(d.slopes*new.data) + d.inter
post.eq = exp(d)/(1+exp(d))
# Print (disc function, posteriors) and plot results
cat(d.slopes[1], "mag.P +" , d.slopes[2], "mag.S +" , d.inter,"\n")
cat("P(EQ|data) =", post.eq, " P(EX|data) =", 1-post.eq, "\n" )
plot(eq.P, eq.S, xlim=c(0,1.5), ylim=c(.75,1.25), xlab="log mag(P)", ylab ="log mag(S)",
  pch = 8, cex=1.1, lwd=2, main="Classification Based on Magnitude Features")
points(ex.P, ex.S, pch = 6, cex=1.1, lwd=2)
points(new.data, pch = 3, cex=1.1, lwd=2)
abline(a = -d.inter/d.slopes[2], b = -d.slopes[1]/d.slopes[2])
text(eq.P-.07,eq.S+.005, label=names(eqexp[1:8]), cex=.8)
text(ex.P+.07,ex.S+.003, label=names(eqexp[9:16]), cex=.8)
text(NZ.P+.05,NZ.S+.003, label=names(eqexp[17]), cex=.8)
legend("topright",c("EQ","EX","NZ"),pch=c(8,6,3),pt.lwd=2,cex=1.1)
# Cross-validation
all.data = rbind(cbind(eq.P, eq.S), cbind(ex.P, ex.S))
post.eq <- rep(NA, 8) -> post.ex
for(j in 1:16) {
if (j <= 8){samp.eq = all.data[-c(j, 9:16),]
samp.ex = all.data[9:16,]}
if (j > 8){samp.eq = all.data[1:8,]
samp.ex = all.data[-c(j, 1:8),]
 }
df.eq = nrow(samp.eq)-1; df.ex = nrow(samp.ex)-1
mean.eq = colMeans(samp.eq); mean.ex = colMeans(samp.ex)
cov.eq = var(samp.eq); cov.ex = var(samp.ex)
cov.pooled = (df.eq*cov.eq + df.ex*cov.ex)/(df.eq + df.ex)
slopes.eq = solve(cov.pooled, mean.eq)
inter.eq = -sum(slopes.eq*mean.eq)/2
slopes.ex = solve(cov.pooled, mean.ex)
inter.ex = -sum(slopes.ex*mean.ex)/2
d.slopes = slopes.eq - slopes.ex
d.inter = inter.eq - inter.ex
d = sum(d.slopes*all.data[j,]) + d.inter
if (j <= 8) post.eq[j] = exp(d)/(1+exp(d))
if (j > 8) post.ex[j-8] = 1/(1+exp(d)) }
Posterior = cbind(1:8, post.eq, 1:8, post.ex)
colnames(Posterior) = c("EQ","P(EQ|data)","EX","P(EX|data)")
round(Posterior,3) # Results from Cross-validation (not shown)

Frequency Domain Discrimination and Measures of Disparity

P = 1:1024; S = P+1024; p.dim = 2; n =1024
eq = as.ts(eqexp[, 1:8])
ex = as.ts(eqexp[, 9:16])
nz = as.ts(eqexp[, 17])
f.eq <- array(dim=c(8, 2, 2, 512)) -> f.ex
f.NZ = array(dim=c(2, 2, 512))
# below calculates determinant for 2x2 Hermitian matrix
det.c <- function(mat){return(Re(mat[1,1]*mat[2,2]-mat[1,2]*mat[2,1]))}
L = c(15,13,5)
 # for smoothing
for (i in 1:8){
 # compute spectral matrices
f.eq[i,,,] = mvspec(cbind(eq[P,i], eq[S,i]), spans=L, taper=.5)$fxx
f.ex[i,,,] = mvspec(cbind(ex[P,i], ex[S,i]), spans=L, taper=.5)$fxx}
u = mvspec(cbind(nz[P], nz[S]), spans=L, taper=.5)
f.NZ = u$fxx
bndwidth = u$bandwidth*sqrt(12)*40 # about .75 Hz
fhat.eq = apply(f.eq, 2:4, mean)
 # average spectra
fhat.ex = apply(f.ex, 2:4, mean)
# plot the average spectra
par(mfrow=c(2,2), mar=c(3,3,2,1), mgp = c(1.6,.6,0))
Fr = 40*(1:512)/n
plot(Fr,Re(fhat.eq[1,1,]),type="l",xlab="Frequency (Hz)",ylab="")
plot(Fr,Re(fhat.eq[2,2,]),type="l",xlab="Frequency (Hz)",ylab="")
plot(Fr,Re(fhat.ex[1,1,]),type="l",xlab="Frequency (Hz)",ylab="")
plot(Fr,Re(fhat.ex[2,2,]),type="l",xlab="Frequency (Hz)",ylab="")
mtext("Average P-spectra", side=3, line=-1.5, adj=.2, outer=TRUE)
mtext("Earthquakes", side=2, line=-1, adj=.8, outer=TRUE)
mtext("Average S-spectra", side=3, line=-1.5, adj=.82, outer=TRUE)
mtext("Explosions", side=2, line=-1, adj=.2, outer=TRUE)
par(fig = c(.75, 1, .75, 1), new = TRUE)
ker = kernel("modified.daniell", L)$coef; ker = c(rev(ker),ker[-1])
plot((-33:33)/40, ker, type="l", ylab="", xlab="", cex.axis=.7,
yaxp=c(0,.04,2))
# Choose alpha
Balpha = rep(0,19)
for (i in 1:19){ alf=i/20
for (k in 1:256) {
Balpha[i]= Balpha[i] + Re(log(det.c(alf*fhat.ex[,,k] +
(1-alf)*fhat.eq[,,k])/det.c(fhat.eq[,,k])) -
alf*log(det.c(fhat.ex[,,k])/det.c(fhat.eq[,,k])))} }
alf = which.max(Balpha)/20
 # alpha = .4
# Calculate Information Criteria
rep(0,17) -> KLDiff -> BDiff -> KLeq -> KLex -> Beq -> Bex
for (i in 1:17){
if (i <= 8) f0 = f.eq[i,,,]
if (i > 8 & i <= 16) f0 = f.ex[i-8,,,]
if (i == 17) f0 = f.NZ
for (k in 1:256) {
 # only use freqs out to .25
tr = Re(sum(diag(solve(fhat.eq[,,k],f0[,,k]))))
KLeq[i] = KLeq[i] + tr + log(det.c(fhat.eq[,,k])) - log(det.c(f0[,,k]))
Beq[i] = Beq[i] + Re(log(det.c(alf*f0[,,k]+(1-alf)*fhat.eq[,,k])/det.c(fhat.eq[,,k])) -
   alf*log(det.c(f0[,,k])/det.c(fhat.eq[,,k])))
tr = Re(sum(diag(solve(fhat.ex[,,k],f0[,,k]))))
KLex[i] = KLex[i] + tr + log(det.c(fhat.ex[,,k])) - log(det.c(f0[,,k]))
Bex[i] = Bex[i] + Re(log(det.c(alf*f0[,,k]+(1-alf)*fhat.ex[,,k])/det.c(fhat.ex[,,k])) -
   alf*log(det.c(f0[,,k])/det.c(fhat.ex[,,k]))) }
KLDiff[i] = (KLeq[i] - KLex[i])/n
BDiff[i] = (Beq[i] - Bex[i])/(2*n) }
x.b = max(KLDiff)+.1; x.a = min(KLDiff)-.1
y.b = max(BDiff)+.01; y.a = min(BDiff)-.01
dev.new()
plot(KLDiff[9:16], BDiff[9:16], type="p", xlim=c(x.a,x.b), ylim=c(y.a,y.b),
cex=1.1,lwd=2, xlab="Kullback-Leibler Difference",ylab="Chernoff
Difference", main="Classification Based on Chernoff and K-L
Distances", pch=6)
points(KLDiff[1:8], BDiff[1:8], pch=8, cex=1.1, lwd=2)
points(KLDiff[17], BDiff[17], pch=3, cex=1.1, lwd=2)
legend("topleft", legend=c("EQ", "EX", "NZ"), pch=c(8,6,3), pt.lwd=2)
abline(h=0, v=0, lty=2, col="gray")
text(KLDiff[-c(1,2,3,7,14)]-.075, BDiff[-c(1,2,3,7,14)],
label=names(eqexp[-c(1,2,3,7,14)]), cex=.7)
text(KLDiff[c(1,2,3,7,14)]+.075, BDiff[c(1,2,3,7,14)],
label=names(eqexp[c(1,2,3,7,14)]), cex=.7)

Example 7.12 Cluster Analysis for Earthquakes and Explosions

library(cluster)
P = 1:1024; S = P+1024; p.dim = 2; n =1024
eq = as.ts(eqexp[, 1:8])
ex = as.ts(eqexp[, 9:16])
nz = as.ts(eqexp[, 17])
f = array(dim=c(17, 2, 2, 512))
L = c(15, 15)
 # for smoothing
for (i in 1:8){
 # compute spectral matrices
f[i,,,] = mvspec(cbind(eq[P,i], eq[S,i]), spans=L, taper=.5)$fxx
f[i+8,,,] = mvspec(cbind(ex[P,i], ex[S,i]), spans=L, taper=.5)$fxx }
f[17,,,] = mvspec(cbind(nz[P], nz[S]), spans=L, taper=.5)$fxx
JD = matrix(0, 17, 17)
# Calculate Symmetric Information Criteria
for (i in 1:16){
for (j in (i+1):17){
for (k in 1:256) {
 # only use freqs out to .25
tr1 = Re(sum(diag(solve(f[i,,,k], f[j,,,k]))))
tr2 = Re(sum(diag(solve(f[j,,,k], f[i,,,k]))))
JD[i,j] = JD[i,j] + (tr1 + tr2 - 2*p.dim)}}}
JD = (JD + t(JD))/n
colnames(JD) = c(colnames(eq), colnames(ex), "NZ")
rownames(JD) = colnames(JD)
cluster.2 = pam(JD, k = 2, diss = TRUE)
summary(cluster.2) # print results
par(mgp = c(1.6,.6,0), cex=3/4, cex.lab=4/3, cex.main=4/3)
clusplot(JD, cluster.2$cluster, col.clus=1, labels=3, lines=0, col.p=1,
main="Clustering Results for Explosions and Earthquakes")
text(-7,-.5, "Group I", cex=1.1, font=2)
text(1, 5, "Group II", cex=1.1, font=2)

7.8 Principal Components and Factor Analysis

Related topics of spectral domain PCA and factor analysis for time series. Canonical presentation is Brillinger 1981, Chapters 9 and 10.

Example 7.13 PCA of the fMRI Data

n = 128; Per = abs(mvfft(fmri1[,-1]))^2/n
par(mfrow=c(2,4), mar=c(3,2,2,1), mgp = c(1.6,.6,0), oma=c(0,1,0,0))
for (i in 1:8){ plot(0:20, Per[1:21,i], type="l", ylim=c(0,8),
main=colnames(fmri1)[i+1], xlab="Cycles",ylab="", xaxp=c(0,20,5))}
mtext("Periodogram", side=2, line=-.3, outer=TRUE, adj=c(.2,.8))
dev.new()
fxx = mvspec(fmri1[,-1], kernel("daniell", c(1,1)), taper=.5, plot=FALSE)$fxx
l.val = rep(NA,64)
for (k in 1:64) {
u = eigen(fxx[,,k], symmetric=TRUE, only.values = TRUE)
l.val[k] = u$values[1]} # largest e-value
plot(l.val, type="n", xaxt="n", xlab="Cycles (Frequency x 128)", ylab="First
Principal Component")
axis(1, seq(4,60,by=8)); grid(lty=2, nx=NA, ny=NULL)
abline(v=seq(4,60,by=8), col='lightgray', lty=2); lines(l.val)
# At freq 4/128
u = eigen(fxx[,,4], symmetric=TRUE)
lam=u$values; evec=u$vectors
lam[1]/sum(lam)
 # % of variance explained
sig.e1 = matrix(0,8,8)
for (l in 2:5){
 # last 3 evs are 0
sig.e1 = sig.e1 + lam[l]*evec[,l]%*%Conj(t(evec[,l]))/(lam[1]-lam[l])^2}
sig.e1 = Re(sig.e1)*lam[1]*sum(kernel("daniell", c(1,1))$coef^2)
p.val = round(pchisq(2*abs(evec[,1])^2/diag(sig.e1), 2, lower.tail=FALSE), 3)
cbind(colnames(fmri1)[-1], abs(evec[,1]), p.val) # table values

Example 7.14 Single Factor Analysis of the fMRI Data

bhat = sqrt(lam[1])*evec[,1]
Dhat = Re(diag(fxx[,,4] - bhat%*%Conj(t(bhat))))
res = Mod(fxx[,,4] - Dhat - bhat%*%Conj(t(bhat)))

Example 7.15 Government Spending, Private Investment and Unemployment

gr = diff(log(ts(econ5, start=1948, frequency=4))) # growth rate
plot(100*gr, main="Growth Rates (%)")
# scale each series to have variance 1
gr = ts(apply(gr,2,scale), freq=4)
 # scaling strips ts attributes
L = c(7,7)
 # degree of smoothing
gr.spec = mvspec(gr, spans=L, demean=FALSE, detrend=FALSE, taper=.25)
dev.new()
plot(kernel("modified.daniell", L)) # view the kernel - not shown
dev.new()
plot(gr.spec, log="no", main="Individual Spectra", lty=1:5, lwd=2)
legend("topright", colnames(econ5), lty=1:5, lwd=2)
dev.new()
plot.spec.coherency(gr.spec, ci=NA, main="Squared Coherencies")
# PCs
n.freq = length(gr.spec$freq)
lam = matrix(0,n.freq,5)
for (k in 1:n.freq) lam[k,] = eigen(gr.spec$fxx[,,k], symmetric=TRUE,
    only.values=TRUE)$values
dev.new()
par(mfrow=c(2,1), mar=c(4,2,2,1), mgp=c(1.6,.6,0))
plot(gr.spec$freq, lam[,1], type="l", ylab="", xlab="Frequency", main="First
Eigenvalue")
abline(v=.25, lty=2)
plot(gr.spec$freq, lam[,2], type="l", ylab="", xlab="Frequency",
main="Second Eigenvalue")
abline(v=.125, lty=2)
e.vec1 = eigen(gr.spec$fxx[,,10], symmetric=TRUE)$vectors[,1]
e.vec2 = eigen(gr.spec$fxx[,,5], symmetric=TRUE)$vectors[,2]
round(Mod(e.vec1), 2); round(Mod(e.vec2),3)

7.9 The Spectral Envelope

Motivated by collaborations with researchers who collected categorical-valued time series with an interest in the cyclic behavior of the data.

Example 7.17 Analysis of an Epstein-Barr Virus Gene

u = factor(bnrf1ebv) # first, input the data as factors and then
x = model.matrix(~u-1)[,1:3] # make an indicator matrix
# x = x[1:1000,] # select subsequence if desired
Var = var(x) # var-cov matrix
xspec = mvspec(x, spans=c(7,7), plot=FALSE)
fxxr = Re(xspec$fxx) # fxxr is real(fxx)
# compute Q = Var^-1/2
ev = eigen(Var)
Q = ev$vectors%*%diag(1/sqrt(ev$values))%*%t(ev$vectors)
# compute spec envelope and scale vectors
num = xspec$n.used # sample size used for FFT
nfreq = length(xspec$freq)
 # number of freqs used
specenv = matrix(0,nfreq,1) # initialize the spec envelope
beta = matrix(0,nfreq,3)
 # initialize the scale vectors
for (k in 1:nfreq){
ev = eigen(2*Q%*%fxxr[,,k]%*%Q/num, symmetric=TRUE)
specenv[k] = ev$values[1] # spec env at freq k/n is max evalue
b = Q%*%ev$vectors[,1]
 # beta at freq k/n
beta[k,] = b/sqrt(sum(b^2)) } # helps to normalize beta
# output and graphics
frequency = xspec$freq
plot(frequency, 100*specenv, type="l", ylab="Spectral Envelope (%)")
# add significance threshold to plot
m = xspec$kernel$m
etainv = sqrt(sum(xspec$kernel[-m:m]^2))
thresh=100*(2/num)*exp(qnorm(.9999)*etainv)
abline(h=thresh, lty=6, col=4)
# details
output = cbind(frequency, specenv, beta)
colnames(output) = c("freq","specenv", "A", "C", "G")
round(output,3)

Example 7.18 Optimal Transformations for Financial Data: NYSE Returns

u = astsa::nyse
 # accept no substitutes
x = cbind(u, abs(u), u^2)
Var = var(x)
 # var-cov matrix
xspec = mvspec(x, spans=c(5,3), taper=.5, plot=FALSE)
fxxr = Re(xspec$fxx)
 # fxxr is real(fxx)
# compute Q = Var^-1/2
ev = eigen(Var)
Q = ev$vectors%*%diag(1/sqrt(ev$values))%*%t(ev$vectors)
# compute spec env and scale vectors
num = xspec$n.used
 # sample size used for FFT
nfreq = length(xspec$freq)
 # number of freqs used
specenv = matrix(0,nfreq,1)
 # initialize the spec envelope
beta = matrix(0,nfreq,3)
 # initialize the scale vectors
for (k in 1:nfreq){
ev = eigen(2*Q%*%fxxr[,,k]%*%Q/num) # get evalues of normalized spectral
#matrix at freq k/n
specenv[k] = ev$values[1]
 # spec env at freq k/n is max evalue
b = Q%*%ev$vectors[,1]
 # beta at freq k/n
beta[k,] = b/b[1]
}
 # first coef is always 1
# output and graphics
par(mar=c(2.5,2.75,.5,.5), mgp=c(1.5,.6,0))
frequency = xspec$freq
plot(frequency, 100*specenv, type="l", ylab="Spectral Envelope (%)")
m = xspec$kernel$m
etainv = sqrt(sum(xspec$kernel[-m:m]^2))
thresh = 100*(2/num)*exp(qnorm(.9999)*etainv)*matrix(1,nfreq,1)
lines(frequency, thresh, lty=2, col=4)
# details
b = sign(b[2])*output[2,3:5]
 # sign of |x| positive for beauty
output = cbind(frequency, specenv, beta)
colnames(output)=c("freq","specenv","x", "|x|", "x^2"); round(output, 4)
dev.new(); par(mar=c(2.5,2.5,.5,.5), mgp=c(1.5,.6,0))
# plot transform
g = function(x) { b[1]*x+b[2]*abs(x)+b[3]*x^2 }
curve(g, -.2, .2, panel.first=grid(lty=2))
g2 = function(x) { b[2]*abs(x) }
 # corresponding |x|
curve(g2, -.2,.2, add=TRUE, lty=6, col=4)